code:
{- git-annex assistant webapp configurators for Amazon AWS services
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.AWS where

import Assistant.WebApp.Common
import Assistant.WebApp.MakeRemote
#ifdef WITH_S3
import qualified Remote.S3 as S3
#endif
import qualified Remote.Glacier as Glacier
import qualified Remote.Helper.AWS as AWS
import Logs.Remote
import qualified Remote
import qualified Types.Remote as Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Creds
import Assistant.Gpg
import Git.Types (RemoteName)

import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char

awsConfigurator :: Widget -> Handler Html
awsConfigurator = page "Add an Amazon repository" (Just Configuration)

glacierConfigurator :: Widget -> Handler Html
glacierConfigurator a = do
	ifM (liftIO $ inPath "glacier")
		( awsConfigurator a
		, awsConfigurator needglaciercli
		)
  where
	needglaciercli = $(widgetFile "configurators/needglaciercli")

data StorageClass = StandardRedundancy | ReducedRedundancy
	deriving (Eq, Enum, Bounded)

instance Show StorageClass where
	show StandardRedundancy = "STANDARD"
	show ReducedRedundancy = "REDUCED_REDUNDANCY"

data AWSInput = AWSInput
	{ accessKeyID :: Text
	, secretAccessKey :: Text
	, datacenter :: Text
	-- Only used for S3, not Glacier.
	, storageClass :: StorageClass
	, repoName :: Text
	, enableEncryption :: EnableEncryption
	}

data AWSCreds = AWSCreds Text Text

extractCreds :: AWSInput -> AWSCreds
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)

s3InputAForm :: Maybe CredPair -> MkAForm AWSInput
s3InputAForm defcreds = AWSInput
	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
	<*> datacenterField AWS.S3
	<*> areq (selectFieldList storageclasses) (bfs "Storage class") (Just StandardRedundancy)
	<*> areq textField (bfs "Repository name") (Just "S3")
	<*> enableEncryptionField
  where
	storageclasses :: [(Text, StorageClass)]
	storageclasses =
		[ ("Standard redundancy", StandardRedundancy)
		, ("Reduced redundancy (costs less)", ReducedRedundancy)
		]

glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput
glacierInputAForm defcreds = AWSInput
	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
	<*> datacenterField AWS.Glacier
	<*> pure StandardRedundancy
	<*> areq textField (bfs "Repository name") (Just "glacier")
	<*> enableEncryptionField

awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
awsCredsAForm defcreds = AWSCreds
	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
	<*> secretAccessKeyField (T.pack . snd <$> defcreds)

accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
accessKeyIDField help = areq (textField `withNote` help) (bfs "Access Key ID")

accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
accessKeyIDFieldWithHelp = accessKeyIDField help
  where
	help = [whamlet|
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
  Get Amazon access keys
|]

secretAccessKeyField :: Maybe Text -> MkAForm Text
secretAccessKeyField = areq passwordField (bfs "Secret Access Key")

datacenterField :: AWS.Service -> MkAForm Text
datacenterField service = areq (selectFieldList list) (bfs "Datacenter") defregion
  where
	list = M.toList $ AWS.regionMap service
	defregion = Just $ AWS.defaultRegion service

getAddS3R :: Handler Html
getAddS3R = postAddS3R

postAddS3R :: Handler Html
#ifdef WITH_S3
postAddS3R = awsConfigurator $ do
	defcreds <- liftAnnex previouslyUsedAWSCreds
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ s3InputAForm defcreds
	case result of
		FormSuccess input -> liftH $ do
			let name = T.unpack $ repoName input
			makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList
				[ configureEncryption $ enableEncryption input
				, ("type", "S3")
				, ("datacenter", T.unpack $ datacenter input)
				, ("storageclass", show $ storageClass input)
				]
		_ -> $(widgetFile "configurators/adds3")
#else
postAddS3R = error "S3 not supported by this build"
#endif

getAddGlacierR :: Handler Html
getAddGlacierR = postAddGlacierR

postAddGlacierR :: Handler Html
#ifdef WITH_S3
postAddGlacierR = glacierConfigurator $ do
	defcreds <- liftAnnex previouslyUsedAWSCreds
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ glacierInputAForm defcreds
	case result of
		FormSuccess input -> liftH $ do
			let name = T.unpack $ repoName input
			makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList
				[ configureEncryption $ enableEncryption input
				, ("type", "glacier")
				, ("datacenter", T.unpack $ datacenter input)
				]
		_ -> $(widgetFile "configurators/addglacier")
#else
postAddGlacierR = error "S3 not supported by this build"
#endif

getEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
getEnableS3R uuid = do
	m <- liftAnnex readRemoteLog
	if isIARemoteConfig $ fromJust $ M.lookup uuid m
		then redirect $ EnableIAR uuid
		else postEnableS3R uuid
#else
getEnableS3R = postEnableS3R
#endif

postEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
#else
postEnableS3R _ = error "S3 not supported by this build"
#endif

getEnableGlacierR :: UUID -> Handler Html
getEnableGlacierR = postEnableGlacierR

postEnableGlacierR :: UUID -> Handler Html
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote

enableAWSRemote :: RemoteType -> UUID -> Widget
#ifdef WITH_S3
enableAWSRemote remotetype uuid = do
	defcreds <- liftAnnex previouslyUsedAWSCreds
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds
	case result of
		FormSuccess creds -> liftH $ do
			m <- liftAnnex readRemoteLog
			let name = fromJust $ M.lookup "name" $
				fromJust $ M.lookup uuid m
			makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty
		_ -> do
			description <- liftAnnex $
				T.pack <$> Remote.prettyUUID uuid
			$(widgetFile "configurators/enableaws")
#else
enableAWSRemote _ _ = error "S3 not supported by this build"
#endif

makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config =
	setupCloudRemote defaultgroup Nothing $
		maker hostname remotetype (Just creds) config
  where
  	creds = (T.unpack ak, T.unpack sk)
	{- AWS services use the remote name as the basis for a host
	 - name, so filter it to contain valid characters. -}
	hostname = case filter isAlphaNum name of
		[] -> "aws"
		n -> n

getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
  where
	bucket = fromMaybe "" $ M.lookup "bucket" c

#ifdef WITH_S3
isIARemoteConfig :: RemoteConfig -> Bool
isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host"

previouslyUsedAWSCreds :: Annex (Maybe CredPair)
previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote]
  where
	gettype t = previouslyUsedCredPair AWS.creds t $
		not . isIARemoteConfig . Remote.config
#endif


code:
{- git-annex assistant webapp repository deletion
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Delete where

import Assistant.WebApp.Common
import Assistant.DeleteRemote
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.Sync
import qualified Remote
import qualified Git
import Config.Files
import Utility.FileMode
import Logs.Trust
import Logs.Remote
import Logs.PreferredContent
import Types.StandardGroups
import Annex.UUID

import System.IO.HVFS (SystemFS(..))
import qualified Data.Text as T
import qualified Data.Map as M
import System.Path

notCurrentRepo :: UUID -> Handler Html -> Handler Html
notCurrentRepo uuid a = do
	u <- liftAnnex getUUID
	if u == uuid
		then redirect DeleteCurrentRepositoryR
		else go =<< liftAnnex (Remote.remoteFromUUID uuid)
  where
  	go Nothing = error "Unknown UUID"
	go (Just _) = a

handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
handleXMPPRemoval uuid nonxmpp = do
	remote <- fromMaybe (error "unknown remote")
		<$> liftAnnex (Remote.remoteFromUUID uuid)
	if Remote.isXMPPRemote remote
		then deletionPage $ $(widgetFile "configurators/delete/xmpp")
		else nonxmpp

getDisableRepositoryR :: UUID -> Handler Html
getDisableRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
	void $ liftAssistant $ disableRemote uuid
	redirect DashboardR

getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
	deletionPage $ do
		reponame <- liftAnnex $ Remote.prettyUUID uuid
		$(widgetFile "configurators/delete/start")

getStartDeleteRepositoryR :: UUID -> Handler Html
getStartDeleteRepositoryR uuid = do
	remote <- fromMaybe (error "unknown remote")
		<$> liftAnnex (Remote.remoteFromUUID uuid)
	liftAnnex $ do
		trustSet uuid UnTrusted
		setStandardGroup uuid UnwantedGroup
	liftAssistant $ addScanRemotes True [remote]
	redirect DashboardR

getFinishDeleteRepositoryR :: UUID -> Handler Html
getFinishDeleteRepositoryR uuid = deletionPage $ do
	void $ liftAssistant $ removeRemote uuid

	reponame <- liftAnnex $ Remote.prettyUUID uuid
	{- If it's not listed in the remote log, it must be a git repo. -}
	gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
	$(widgetFile "configurators/delete/finished")

getDeleteCurrentRepositoryR :: Handler Html
getDeleteCurrentRepositoryR = deleteCurrentRepository

postDeleteCurrentRepositoryR :: Handler Html
postDeleteCurrentRepositoryR = deleteCurrentRepository

deleteCurrentRepository :: Handler Html
deleteCurrentRepository = dangerPage $ do
	reldir <- fromJust . relDir <$> liftH getYesod
	havegitremotes <- haveremotes syncGitRemotes
	havedataremotes <- haveremotes syncDataRemotes
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
			sanityVerifierAForm $ SanityVerifier magicphrase
	case result of
		FormSuccess _ -> liftH $ do
			dir <- liftAnnex $ fromRepo Git.repoPath
			liftIO $ removeAutoStartFile dir

			{- Disable syncing to this repository, and all
			 - remotes. This stops all transfers, and all
			 - file watching. -}
			liftAssistant $ do
				changeSyncable Nothing False
				rs <- syncRemotes <$> getDaemonStatus
				mapM_ (\r -> changeSyncable (Just r) False) rs

			{- Make all directories writable and files writable
			 - so all annexed content can be deleted. -}
			liftIO $ do
				recurseDir SystemFS dir
					>>= mapM_ (void . tryIO . allowWrite)
				removeDirectoryRecursive dir

			redirect ShutdownConfirmedR
		_ -> $(widgetFile "configurators/delete/currentrepository")
  where
	haveremotes selector = not . null . selector
		<$> liftAssistant getDaemonStatus

data SanityVerifier = SanityVerifier T.Text
	deriving (Eq)

sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
sanityVerifierAForm template = SanityVerifier
	<$> areq checksanity (bfs "Confirm deletion?") Nothing
  where
	checksanity = checkBool (\input -> SanityVerifier input == template)
		insane textField

	insane = "Maybe this is not a good idea..." :: Text

deletionPage :: Widget -> Handler Html
deletionPage = page "Delete repository" (Just Configuration)

dangerPage :: Widget -> Handler Html
dangerPage = page "Danger danger danger" (Just Configuration)

magicphrase :: Text
magicphrase = "Yes, please do as I say!"

repo_name: kakafarm/git

license: unknown


code:
{- git-annex assistant webapp configurator for editing existing repos
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Edit where

import Assistant.WebApp.Common
import Assistant.WebApp.Gpg
import Assistant.WebApp.Configurators
import Assistant.DaemonStatus
import Assistant.WebApp.MakeRemote (uniqueRemoteName)
import Assistant.ScanRemotes
import Assistant.Sync
import Assistant.Alert
import qualified Assistant.WebApp.Configurators.AWS as AWS
import qualified Assistant.WebApp.Configurators.IA as IA
#ifdef WITH_S3
import qualified Remote.S3 as S3
#endif
import qualified Remote
import qualified Types.Remote as Remote
import qualified Remote.List as Remote
import Logs.UUID
import Logs.Group
import Logs.PreferredContent
import Logs.Remote
import Types.StandardGroups
import qualified Git
import qualified Git.Types as Git
import qualified Git.Command
import qualified Git.Config
import qualified Annex
import Git.Remote
import Remote.Helper.Encryptable (extractCipher)
import Types.Crypto
import Utility.Gpg
import Annex.UUID
import Assistant.Ssh
import Config

import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Set as S

data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
	deriving (Show, Eq)

data RepoConfig = RepoConfig
	{ repoName :: Text
	, repoDescription :: Maybe Text
	, repoGroup :: RepoGroup
	, repoAssociatedDirectory :: Maybe Text
	, repoSyncable :: Bool
	}
	deriving (Show)

getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
getRepoConfig uuid mremote = do
	-- Ensure we're editing current data by discarding caches.
	void groupMapLoad
	void uuidMapLoad

	groups <- lookupGroups uuid
	remoteconfig <- M.lookup uuid <$> readRemoteLog
	let (repogroup, associateddirectory) = case getStandardGroup groups of
		Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
		Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)

	description <- fmap T.pack . M.lookup uuid <$> uuidMap

	syncable <- case mremote of
		Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
		Nothing -> annexAutoCommit <$> Annex.getGitConfig

	return $ RepoConfig
		(T.pack $ maybe "here" Remote.name mremote)
		description
		repogroup
		(T.pack <$> associateddirectory)
		syncable

setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
setRepoConfig uuid mremote oldc newc = do
	when descriptionChanged $ liftAnnex $ do
		maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)
		void uuidMapLoad
	when nameChanged $ do
		liftAnnex $ do
			name <- fromRepo $ uniqueRemoteName (legalName newc) 0
			{- git remote rename expects there to be a
			 - remote.<name>.fetch, and exits nonzero if
			 - there's not. Special remotes don't normally
			 - have that, and don't use it. Temporarily add
			 - it if it's missing. -}
			let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch"
			needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch)
			when needfetch $
				inRepo $ Git.Command.run
					[Param "config", Param remotefetch, Param ""]
			inRepo $ Git.Command.run
				[ Param "remote"
				, Param "rename"
				, Param $ T.unpack $ repoName oldc
				, Param name
				]
			void Remote.remoteListRefresh
		liftAssistant updateSyncRemotes
	when associatedDirectoryChanged $ case repoAssociatedDirectory newc of
		Nothing -> noop
		Just t
			| T.null t -> noop
			| otherwise -> liftAnnex $ do
				let dir = takeBaseName $ T.unpack t
				m <- readRemoteLog
				case M.lookup uuid m of
					Nothing -> noop
					Just remoteconfig -> configSet uuid $
						M.insert "preferreddir" dir remoteconfig
	when groupChanged $ do
		liftAnnex $ case repoGroup newc of
			RepoGroupStandard g -> setStandardGroup uuid g
			RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
		{- Enabling syncing will cause a scan,
		 - so avoid queueing a duplicate scan. -}
		when (repoSyncable newc && not syncableChanged) $ liftAssistant $
			case mremote of
				Just remote -> addScanRemotes True [remote]
				Nothing -> addScanRemotes True
					=<< syncDataRemotes <$> getDaemonStatus
	when syncableChanged $
		liftAssistant $ changeSyncable mremote (repoSyncable newc)
  where
  	syncableChanged = repoSyncable oldc /= repoSyncable newc
	associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc
	groupChanged = repoGroup oldc /= repoGroup newc
	nameChanged = isJust mremote && legalName oldc /= legalName newc
	descriptionChanged = repoDescription oldc /= repoDescription newc

	legalName = makeLegalName . T.unpack . repoName

editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
editRepositoryAForm mremote def = RepoConfig
	<$> areq (if ishere then readonlyTextField else textField)
		(bfs "Name") (Just $ repoName def)
	<*> aopt textField (bfs "Description") (Just $ repoDescription def)
	<*> areq (selectFieldList groups `withNote` help) (bfs "Repository group") (Just $ repoGroup def)
	<*> associateddirectory
	<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
  where
	ishere = isNothing mremote
	isspecial = fromMaybe False $
		(== Git.Unknown) . Git.location . Remote.repo <$> mremote
	groups = customgroups ++ standardgroups
	standardgroups :: [(Text, RepoGroup)]
	standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $
		filter sanegroup [minBound..maxBound]
	sanegroup
		| isspecial = const True
		| otherwise = not . specialRemoteOnly
	customgroups :: [(Text, RepoGroup)]
	customgroups = case repoGroup def of
		RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
		_ -> []
	help = [whamlet|What's this?|]

	associateddirectory = case repoAssociatedDirectory def of
		Nothing -> aopt hiddenField "" Nothing
		Just d -> aopt textField (bfs "Associated directory") (Just $ Just d)

getEditRepositoryR :: RepoId -> Handler Html
getEditRepositoryR = postEditRepositoryR

postEditRepositoryR :: RepoId -> Handler Html
postEditRepositoryR = editForm False

getEditNewRepositoryR :: UUID -> Handler Html
getEditNewRepositoryR = postEditNewRepositoryR

postEditNewRepositoryR :: UUID -> Handler Html
postEditNewRepositoryR = editForm True . RepoUUID

getEditNewCloudRepositoryR :: UUID -> Handler Html
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR

postEditNewCloudRepositoryR :: UUID -> Handler Html
postEditNewCloudRepositoryR uuid = connectionNeeded >> editForm True (RepoUUID uuid)

editForm :: Bool -> RepoId -> Handler Html
editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
	when (mremote == Nothing) $
		whenM ((/=) uuid <$> liftAnnex getUUID) $
			error "unknown remote"
	curr <- liftAnnex $ getRepoConfig uuid mremote
	liftAnnex $ checkAssociatedDirectory curr mremote
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
	case result of
		FormSuccess input -> liftH $ do
			setRepoConfig uuid mremote curr input
			liftAnnex $ checkAssociatedDirectory input mremote
			redirect DashboardR
		_ -> do
			let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
			config <- liftAnnex $ M.lookup uuid <$> readRemoteLog
			let repoInfo = getRepoInfo mremote config
			let repoEncryption = getRepoEncryption mremote config
			$(widgetFile "configurators/edit/repository")
editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
	mr <- liftAnnex (repoIdRemote r)
	let repoInfo = getRepoInfo mr Nothing
	g <- liftAnnex gitRepo
	let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation . Remote.repo) mr
	$(widgetFile "configurators/edit/nonannexremote")

{- Makes any directory associated with the repository. -}
checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
checkAssociatedDirectory _ Nothing = noop
checkAssociatedDirectory cfg (Just r) = do
	repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog
	case repoGroup cfg of
		RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
			Just d -> inRepo $ \g ->
				createDirectoryIfMissing True $
					Git.repoPath g </> d
			Nothing -> noop
		_ -> noop

getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
	Just "S3"
#ifdef WITH_S3
		| S3.isIA c -> IA.getRepoInfo c
#endif
		| otherwise -> AWS.getRepoInfo c
	Just t
		| t /= "git" -> [whamlet|#{t} remote|]
	_ -> getGitRepoInfo $ Remote.repo r
getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
getRepoInfo _ _ = [whamlet|git repository|]

getGitRepoInfo :: Git.Repo -> Widget
getGitRepoInfo r = do
	let loc = Git.repoLocation r
	[whamlet|git repository located at <tt>#{loc}</tt>|]

getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
getRepoEncryption (Just _) (Just c) = case extractCipher c of
  	Nothing ->
		[whamlet|not encrypted|]
	(Just (SharedCipher _)) ->
		[whamlet|encrypted: encryption key stored in git repository|]
	(Just (EncryptedCipher _ _ (KeyIds { keyIds = ks }))) -> do
		knownkeys <- liftIO secretKeys
		[whamlet|
encrypted using gpg key:

  $forall k <- ks

      ^{gpgKeyDisplay k (M.lookup k knownkeys)}
|]
getRepoEncryption _ _ = return () -- local repo

getUpgradeRepositoryR  :: RepoId -> Handler ()
getUpgradeRepositoryR (RepoUUID _) = redirect DashboardR
getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
  where
  	go Nothing = redirect DashboardR
	go (Just rmt) = do
		liftIO fixSshKeyPairIdentitiesOnly
		liftAnnex $ setConfig
			(remoteConfig (Remote.repo rmt) "ignore")
			(Git.Config.boolConfig False)
		liftAnnex $ void Remote.remoteListRefresh
		liftAssistant updateSyncRemotes
		liftAssistant $ syncRemote rmt
		redirect DashboardR

{- If there is no currently connected remote, display an alert suggesting
 - to set up one. -}
connectionNeeded :: Handler ()
connectionNeeded = whenM noconnection $ do
	urlrender <- getUrlRender
	void $ liftAssistant $ do
		close <- asIO1 removeAlert
		addAlert $ connectionNeededAlert $ AlertButton
			{ buttonLabel = "Connect"
			, buttonUrl = urlrender ConnectionNeededR
			, buttonAction = Just close
			, buttonPrimary = True
			}
  where
	noconnection = S.null . currentlyConnectedRemotes <$> liftAssistant getDaemonStatus

getConnectionNeededR :: Handler Html
getConnectionNeededR = page "Connection needed" (Just Configuration) $ do
	$(widgetFile "configurators/needconnection")


code:
{- git-annex assistant fsck configuration
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Fsck where

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

import Assistant.WebApp.Common
import Types.ScheduledActivity
import Utility.HumanTime
import Utility.Scheduled
import Logs.Schedule
import Annex.UUID
import qualified Remote
import Assistant.DaemonStatus
import qualified Annex.Branch
import Assistant.Fsck
import Config
import Git.Config
import qualified Annex

{- This adds a form to the page. It does not handle posting of the form,
 - because unlike a typical yesod form that posts using the same url
 - that generated it, this form posts using one of two other routes. -}
showFsckForm :: Bool -> ScheduledActivity -> Widget
showFsckForm new activity = do
	u <- liftAnnex getUUID
	let action = if new
		then AddActivityR u
		else ChangeActivityR u activity
	((res, form), enctype) <- liftH $ runFsckForm new activity
	case res of
		FormSuccess _ -> noop
		_ -> $(widgetFile "configurators/fsck/form")

{- This does not display a form, but it does get it from a post, and run
 - some Annex action on it. -}
withFsckForm :: (ScheduledActivity -> Annex ()) -> Handler ()
withFsckForm a = do
	((res, _form), _enctype) <- runFsckForm False $ defaultFsck Nothing
	case res of
		FormSuccess activity -> liftAnnex $ a activity
		_ -> noop

mkFsck :: UUID -> UUID -> Schedule -> Duration -> ScheduledActivity
mkFsck hereu u s d
	| u == hereu = ScheduledSelfFsck s d
	| otherwise = ScheduledRemoteFsck u s d

runFsckForm :: Bool -> ScheduledActivity -> Handler ((FormResult ScheduledActivity, Widget), Enctype)
runFsckForm new activity = case activity of
	ScheduledSelfFsck s d -> go s d =<< liftAnnex getUUID
	ScheduledRemoteFsck ru s d -> go s d ru
  where
  	go (Schedule r t) d ru = do
		u <- liftAnnex getUUID
		repolist <- liftAssistant (getrepolist ru)
		runFormPostNoToken $ \msg -> do
			(reposRes, reposView) <- mreq (selectFieldList repolist) (bfs "") (Just ru)
			(durationRes, durationView) <- mreq intField (bfs "") (Just $ durationSeconds d `quot` 60 )
			(timeRes, timeView) <- mreq (selectFieldList times) (bfs "") (Just t)
			(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) (bfs "") (Just r)
			let form = do
				webAppFormAuthToken
				$(widgetFile "configurators/fsck/formcontent")
			let formresult = mkFsck
				<$> pure u
				<*> reposRes
				<*> (Schedule <$> recurranceRes <*> timeRes)
				<*> (Duration <$> ((60 *) <$> durationRes))
			return (formresult, form)
	  where
		times :: [(Text, ScheduledTime)]
		times = ensurevalue t (T.pack $ fromScheduledTime t) $
			map (\x -> (T.pack $ fromScheduledTime x, x)) $
				AnyTime : map (\h -> SpecificTime h 0) [0..23]
		recurrances :: [(Text, Recurrance)]
		recurrances = ensurevalue r (T.pack $ fromRecurrance r) $
			[ ("every day", Daily)
			, ("every Sunday", Weekly $ Just 1)
			, ("every Monday", Weekly $ Just 2)
			, ("every Tuesday", Weekly $ Just 3)
			, ("every Wednesday", Weekly $ Just 4)
			, ("every Thursday", Weekly $ Just 5)
			, ("every Friday", Weekly $ Just 6)
			, ("every Saturday", Weekly $ Just 7)
			, ("monthly", Monthly Nothing)
			, ("twice a month", Divisible 2 (Weekly Nothing))
			, ("yearly", Yearly Nothing)
			, ("twice a year", Divisible 6 (Monthly Nothing))
			, ("quarterly", Divisible 4 (Monthly Nothing))
			]
	ensurevalue v desc l = case M.lookup v (M.fromList $ map (\(x,y) -> (y,x)) l) of
		Just _ -> l
		Nothing -> (desc, v) : l
	getrepolist :: UUID -> Assistant [(Text, UUID)]
	getrepolist ensureu = do
		-- It is possible to have fsck jobs for remotes that
		-- do not implement remoteFsck, but it's not too useful,
		-- so omit them from the UI normally.
		remotes <- filter (\r -> Remote.uuid r == ensureu || isJust (Remote.remoteFsck r)) . syncRemotes
			<$> getDaemonStatus
		u <- liftAnnex getUUID
		let us = u : (map Remote.uuid remotes)
		liftAnnex $
			zip <$> (map T.pack <$> Remote.prettyListUUIDs us) <*> pure us

defaultFsck :: Maybe Remote -> ScheduledActivity
defaultFsck Nothing = ScheduledSelfFsck (Schedule Daily AnyTime) (Duration $ 60*60)
defaultFsck (Just r) = ScheduledRemoteFsck (Remote.uuid r) (Schedule Daily AnyTime) (Duration $ 60*60)

showFsckStatus :: ScheduledActivity -> Widget
showFsckStatus activity = do
	m <- liftAnnex getLastRunTimes
	let lastrun = M.lookup activity m
	$(widgetFile "configurators/fsck/status")

getConfigFsckR :: Handler Html
getConfigFsckR = postConfigFsckR
postConfigFsckR :: Handler Html
postConfigFsckR = page "Consistency checks" (Just Configuration) $ do
	scheduledchecks <- liftAnnex $
		S.toList <$> (scheduleGet =<< getUUID)
	rs <- liftAssistant $
		filter fsckableRemote . syncRemotes <$> getDaemonStatus
	recommendedchecks <- liftAnnex $ map defaultFsck
		<$> filterM (not <$$> checkFscked) (Nothing : map Just rs)
	$(widgetFile "configurators/fsck")

changeSchedule :: Handler () -> Handler Html
changeSchedule a = do
	a
	liftAnnex $ Annex.Branch.commit "update"
	redirect ConfigFsckR

getRemoveActivityR :: UUID -> ScheduledActivity -> Handler Html
getRemoveActivityR u activity = changeSchedule $
	liftAnnex $ scheduleRemove u activity

getAddActivityR :: UUID -> Handler Html
getAddActivityR = postAddActivityR
postAddActivityR :: UUID -> Handler Html
postAddActivityR u = changeSchedule $
	withFsckForm $ scheduleAdd u

getChangeActivityR :: UUID -> ScheduledActivity -> Handler Html
getChangeActivityR = postChangeActivityR
postChangeActivityR :: UUID -> ScheduledActivity -> Handler Html
postChangeActivityR u oldactivity = changeSchedule $
	withFsckForm $ \newactivity -> scheduleChange u $
			S.insert newactivity . S.delete oldactivity

data FsckPreferences = FsckPreferences
	{ enableFsckNudge :: Bool
	}

getFsckPreferences :: Annex FsckPreferences
getFsckPreferences = FsckPreferences
	<$> (annexFsckNudge <$> Annex.getGitConfig)

fsckPreferencesAForm :: FsckPreferences -> MkAForm FsckPreferences
fsckPreferencesAForm def = FsckPreferences
	<$> areq (checkBoxField `withNote` nudgenote) "Reminders" (Just $ enableFsckNudge def)
  where
	nudgenote = [whamlet|Remind me when using repositories that lack consistency checks.|]

runFsckPreferencesForm :: Handler ((FormResult FsckPreferences, Widget), Enctype)
runFsckPreferencesForm = do
	prefs <- liftAnnex getFsckPreferences
	runFormPostNoToken $ renderBootstrap3 formLayout $ fsckPreferencesAForm prefs
  where formLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)

showFsckPreferencesForm :: Widget
showFsckPreferencesForm = do
	((res, form), enctype) <- liftH $ runFsckPreferencesForm
	case res of
		FormSuccess _ -> noop
		_ -> $(widgetFile "configurators/fsck/preferencesform")

postConfigFsckPreferencesR :: Handler Html
postConfigFsckPreferencesR = do
	((res, _form), _enctype) <- runFsckPreferencesForm
	case res of
		FormSuccess prefs ->
			liftAnnex $ setConfig (annexConfig "fscknudge")
				(boolConfig $ enableFsckNudge prefs)
		_ -> noop
	redirect ConfigFsckR


code:
{- git-annex assistant webapp configurators for Internet Archive
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.IA where

import Assistant.WebApp.Common
import qualified Assistant.WebApp.Configurators.AWS as AWS
#ifdef WITH_S3
import qualified Remote.S3 as S3
import qualified Remote.Helper.AWS as AWS
import Assistant.WebApp.MakeRemote
#endif
import qualified Remote
import qualified Types.Remote as Remote
import Types.StandardGroups
import Types.Remote (RemoteConfig)
import Logs.Remote
import qualified Annex.Url as Url
import Creds
import Assistant.Gpg

import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char
import Network.URI

iaConfigurator :: Widget -> Handler Html
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)

data IAInput = IAInput
	{ accessKeyID :: Text
	, secretAccessKey :: Text
	, mediaType :: MediaType
	, itemName :: Text
	}

extractCreds :: IAInput -> AWS.AWSCreds
extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i)

{- IA defines only a few media types currently, or the media type
 - may be omitted
 -
 - We add a few other common types, mapped to what we've been told
 - is the closest match.
 -}
data MediaType = MediaImages | MediaAudio | MediaVideo | MediaText | MediaSoftware | MediaOmitted
	deriving (Eq, Ord, Enum, Bounded)

{- Format a MediaType for entry into the IA metadata -}
formatMediaType :: MediaType -> String
formatMediaType MediaText = "texts"
formatMediaType MediaImages = "image"
formatMediaType MediaSoftware = "software"
formatMediaType MediaVideo = "movies"
formatMediaType MediaAudio = "audio"
formatMediaType MediaOmitted = ""

{- A default collection to use for each Mediatype. -}
collectionMediaType :: MediaType -> Maybe String
collectionMediaType MediaText = Just "opensource"
collectionMediaType MediaImages = Just "opensource" -- not ideal
collectionMediaType MediaSoftware = Just "opensource" -- not ideal
collectionMediaType MediaVideo = Just "opensource_movies"
collectionMediaType MediaAudio = Just "opensource_audio"
collectionMediaType MediaOmitted = Just "opensource"

{- Format a MediaType for user display. -}
showMediaType :: MediaType -> String
showMediaType MediaText = "texts"
showMediaType MediaImages = "photos & images"
showMediaType MediaSoftware = "software"
showMediaType MediaVideo = "videos & movies"
showMediaType MediaAudio = "audio & music"
showMediaType MediaOmitted = "other"

iaInputAForm :: Maybe CredPair -> MkAForm IAInput
iaInputAForm defcreds = IAInput
	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
	<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
	<*> areq (selectFieldList mediatypes) (bfs "Media Type") (Just MediaOmitted)
	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) (bfs "Item Name") Nothing
  where
	mediatypes :: [(Text, MediaType)]
	mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]

itemNameHelp :: Widget
itemNameHelp = [whamlet|

  Each item stored in the Internet Archive must have a unique name.

  Once you create the item, a special directory will appear #
  with a name matching the item name. Files you put in that directory #
  will be uploaded to your Internet Archive item.
|]

iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds
iaCredsAForm defcreds = AWS.AWSCreds
        <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
        <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)

#ifdef WITH_S3
previouslyUsedIACreds :: Annex (Maybe CredPair)
previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
	AWS.isIARemoteConfig . Remote.config
#endif

accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
accessKeyIDFieldWithHelp = AWS.accessKeyIDField help
  where
	help = [whamlet|

  Get Internet Archive access keys
|]

getAddIAR :: Handler Html
getAddIAR = postAddIAR

postAddIAR :: Handler Html
#ifdef WITH_S3
postAddIAR = iaConfigurator $ do
	defcreds <- liftAnnex previouslyUsedIACreds
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaInputAForm defcreds
	case result of
		FormSuccess input -> liftH $ do
			let name = escapeBucket $ T.unpack $ itemName input
			AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $
				M.fromList $ catMaybes
					[ Just $ configureEncryption NoEncryption
					, Just ("type", "S3")
					, Just ("host", S3.iaHost)
					, Just ("bucket", escapeHeader name)
					, Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input)
					, if mediaType input == MediaOmitted
						then Nothing
						else Just ("x-archive-mediatype", formatMediaType $ mediaType input)
					, (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input)
					-- Make item show up ASAP.
					, Just ("x-archive-interactive-priority", "1")
					, Just ("preferreddir", name)
					]
		_ -> $(widgetFile "configurators/addia")
#else
postAddIAR = error "S3 not supported by this build"
#endif

getEnableIAR :: UUID -> Handler Html
getEnableIAR = postEnableIAR

postEnableIAR :: UUID -> Handler Html
#ifdef WITH_S3
postEnableIAR = iaConfigurator . enableIARemote
#else
postEnableIAR _ = error "S3 not supported by this build"
#endif

#ifdef WITH_S3
enableIARemote :: UUID -> Widget
enableIARemote uuid = do
	defcreds <- liftAnnex previouslyUsedIACreds
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds
	case result of
		FormSuccess creds -> liftH $ do
			m <- liftAnnex readRemoteLog
			let name = fromJust $ M.lookup "name" $
				fromJust $ M.lookup uuid m
			AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty
		_ -> do
			description <- liftAnnex $
				T.pack <$> Remote.prettyUUID uuid
			$(widgetFile "configurators/enableia")
#endif

{- Convert a description into a bucket item name, which will also be
 - used as the repository name, and the preferreddir.
 - IA seems to need only lower case, and no spaces. -}
escapeBucket :: String -> String
escapeBucket = map toLower . replace " " "-"

{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
escapeHeader :: String -> String
escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')

getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = do
	uo <- liftAnnex Url.getUrlOptions
	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url uo
	[whamlet|

  Internet Archive item
$if (not exists)

    The page will only be available once some files #
    have been uploaded, and the Internet Archive has processed them.
|]
  where
  	bucket = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
	url = S3.iaItemUrl bucket
#else
	url = ""
#endif


code:
{- git-annex assistant webapp configurators for making local repositories
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings, RankNTypes, KindSignatures, TypeFamilies #-}

module Assistant.WebApp.Configurators.Local where

import Assistant.WebApp.Common
import Assistant.WebApp.Gpg
import Assistant.WebApp.MakeRemote
import Assistant.Sync
import Assistant.Restart
import Annex.MakeRepo
import qualified Git
import qualified Git.Config
import qualified Git.Command
import qualified Git.Branch
import Config.Files
import Utility.FreeDesktop
import Utility.DiskFree
#ifdef WITH_CLIBS
import Utility.Mounts
#endif
import Utility.DataUnits
import Remote (prettyUUID)
import Annex.UUID
import Types.StandardGroups
import Logs.PreferredContent
import Logs.UUID
import Utility.UserInfo
import Config
import Utility.Gpg
import qualified Remote.GCrypt as GCrypt
import qualified Types.Remote

import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char
import Data.Ord
import qualified Text.Hamlet as Hamlet

data RepositoryPath = RepositoryPath Text
	deriving Show

{- Custom field display for a RepositoryPath, with an icon etc.
 -
 - Validates that the path entered is not empty, and is a safe value
 - to use as a repository. -}
#if MIN_VERSION_yesod(1,2,0)
repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
#else
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
#endif
repositoryPathField autofocus = Field
#if ! MIN_VERSION_yesod_form(1,2,0)
	{ fieldParse = parse
#else
	{ fieldParse = \l _ -> parse l
	, fieldEnctype = UrlEncoded
#endif
	, fieldView = view
	}
  where
	view idAttr nameAttr attrs val isReq =
		[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]

	parse [path]
		| T.null path = nopath
		| otherwise = liftIO $ checkRepositoryPath path
	parse [] = return $ Right Nothing
	parse _ = nopath

	nopath = return $ Left "Enter a location for the repository"

{- As well as checking the path for a lot of silly things, tilde is
 - expanded in the returned path. -}
checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
checkRepositoryPath p = do
	home <- myHomeDir
	let basepath = expandTilde home $ T.unpack p
	path <- absPath basepath
	let parent = parentDir path
	problems <- catMaybes <$> mapM runcheck
		[ (return $ path == "/", "Enter the full path to use for the repository.")
		, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
		, (doesFileExist path, "A file already exists with that name.")
		, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
		, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
		, (not <$> canWrite path, "Cannot write a repository there.")
		]
	return $
		case headMaybe problems of
			Nothing -> Right $ Just $ T.pack basepath
			Just prob -> Left prob
  where
	runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing )
	expandTilde home ('~':'/':path) = home </> path
	expandTilde _ path = path

{- On first run, if run in the home directory, default to putting it in
 - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
 -
 - If run in another directory, that the user can write to,
 - the user probably wants to put it there. Unless that directory
 - contains a git-annex file, in which case the user has probably
 - browsed to a directory with git-annex and run it from there. -}
defaultRepositoryPath :: Bool -> IO FilePath
defaultRepositoryPath firstrun = do
#ifndef mingw32_HOST_OS
	home <- myHomeDir
	currdir <- liftIO getCurrentDirectory
	if home == currdir && firstrun
		then inhome
		else ifM (legit currdir <&&> canWrite currdir)
			( return currdir
			, inhome
			)
#else
	-- On Windows, always default to ~/Desktop/annex or ~/annex,
	-- no cwd handling because the user might be able to write
	-- to the entire drive.
	if firstrun then inhome else inhome
#endif
  where
	inhome = do
		desktop <- userDesktopDir
		ifM (doesDirectoryExist desktop <&&> canWrite desktop)
			( relHome $ desktop </> gitAnnexAssistantDefaultDir
			, return $ "~" </> gitAnnexAssistantDefaultDir
			)
#ifndef mingw32_HOST_OS
	-- Avoid using eg, standalone build's git-annex.linux/ directory
	-- when run from there.
	legit d = not <$> doesFileExist (d </> "git-annex")
#endif

newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do
	(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
		(Just $ T.pack $ addTrailingPathSeparator defpath)
	let (err, errmsg) = case pathRes of
		FormMissing -> (False, "")
		FormFailure l -> (True, concatMap T.unpack l)
		FormSuccess _ -> (False, "")
	let form = do
		webAppFormAuthToken
		$(widgetFile "configurators/newrepository/form")
	return (RepositoryPath <$> pathRes, form)

{- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler Html
getFirstRepositoryR = postFirstRepositoryR
postFirstRepositoryR :: Handler Html
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
	unlessM (liftIO $ inPath "git") $
		error "You need to install git in order to use git-annex!"
#ifdef __ANDROID__
	androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
	let path = "/sdcard/annex"
#else
	let androidspecial = False
	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
#endif
	((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
	case res of
		FormSuccess (RepositoryPath p) -> liftH $
			startFullAssistant (T.unpack p) ClientGroup Nothing
		_ -> $(widgetFile "configurators/newrepository/first")

getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR =
	startFullAssistant "/sdcard/DCIM" SourceGroup $ Just addignore
  where
  	addignore = do
		liftIO $ unlessM (doesFileExist ".gitignore") $
			writeFile ".gitignore" ".thumbnails"
		void $ inRepo $
			Git.Command.runBool [Param "add", File ".gitignore"]

{- Adding a new local repository, which may be entirely separate, or may
 - be connected to the current repository. -}
getNewRepositoryR :: Handler Html
getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
	home <- liftIO myHomeDir
	((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
	case res of
		FormSuccess (RepositoryPath p) -> do
			let path = T.unpack p
			isnew <- liftIO $ makeRepo path False
			u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
			liftIO $ addAutoStartFile path
			liftIO $ startAssistant path
			askcombine u path
		_ -> $(widgetFile "configurators/newrepository")
  where
	askcombine newrepouuid newrepopath = do
		newrepo <- liftIO $ relHome newrepopath
		mainrepo <- fromJust . relDir <$> liftH getYesod
		$(widgetFile "configurators/newrepository/combine")

{- Ensure that a remote's description, group, etc are available by
 - immediately pulling from it. Also spawns a sync to push to it as well. -}
immediateSyncRemote :: Remote -> Assistant ()
immediateSyncRemote r = do
	currentbranch <- liftAnnex (inRepo Git.Branch.current)
	void $ manualPull currentbranch [r]
	syncRemote r

getCombineRepositoryR :: FilePath -> UUID -> Handler Html
getCombineRepositoryR newrepopath newrepouuid = do
	liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename
	redirect $ EditRepositoryR $ RepoUUID newrepouuid
  where
	remotename = takeFileName newrepopath

selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
	<$> pure Nothing
	<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
	<*> areq textField (bfs "Use this directory on the drive:")
		(Just $ T.pack gitAnnexAssistantDefaultDir)
  where
	pairs = zip (map describe drives) (map mountPoint drives)
	describe drive = case diskFree drive of
		Nothing -> mountPoint drive
		Just free ->
			let sz = roughSize storageUnits True free
			in T.unwords
				[ mountPoint drive
				, T.concat ["(", T.pack sz]
				, "free)"
				]
	onlywritable = [whamlet|This list only includes drives you can write to.|]

removableDriveRepository :: RemovableDrive -> FilePath
removableDriveRepository drive =
	T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)

{- Adding a removable drive. -}
getAddDriveR :: Handler Html
getAddDriveR = postAddDriveR
postAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
	removabledrives <- liftIO driveList
	writabledrives <- liftIO $
		filterM (canWrite . T.unpack . mountPoint) removabledrives
	((res, form), enctype) <- liftH $ runFormPostNoToken $
		selectDriveForm (sort writabledrives)
	case res of
		FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive
		_ -> $(widgetFile "configurators/adddrive")

{- The repo may already exist, when adding removable media
 - that has already been used elsewhere. If so, check
 - the UUID of the repo and see if it's one we know. If not,
 - the user must confirm the repository merge.
 -
 - If the repo does not already exist on the drive, prompt about
 - encryption. -}
getConfirmAddDriveR :: RemovableDrive -> Handler Html
getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
	( do
		mu <- liftIO $ probeUUID dir
		case mu of
			Nothing -> maybe askcombine isknownuuid
				=<< liftAnnex (probeGCryptRemoteUUID dir)
			Just driveuuid -> isknownuuid driveuuid
	, newrepo
	)
  where
  	dir = removableDriveRepository drive
  	newrepo = do
		secretkeys <- sortBy (comparing snd) . M.toList
			<$> liftIO secretKeys
		page "Encrypt repository?" (Just Configuration) $
			$(widgetFile "configurators/adddrive/encrypt")
	knownrepo = getFinishAddDriveR drive NoRepoKey
	askcombine = page "Combine repositories?" (Just Configuration) $
		$(widgetFile "configurators/adddrive/combine")
	isknownuuid driveuuid =
		ifM (M.member driveuuid <$> liftAnnex uuidMap)
			( knownrepo
			, askcombine
			)

setupDriveModal :: Widget
setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")

getGenKeyForDriveR :: RemovableDrive -> Handler Html
getGenKeyForDriveR drive = withNewSecretKey $ \keyid ->
	{- Generating a key takes a long time, and
	 - the removable drive may have been disconnected
	 - in the meantime. Check that it is still mounted
	 - before finishing. -}
	ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
		( getFinishAddDriveR drive (RepoKey keyid)
		, getAddDriveR
		)

getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
getFinishAddDriveR drive = go
  where
	go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
		r <- liftAnnex $ addRemote $
			makeGCryptRemote remotename dir keyid
		return (Types.Remote.uuid r, r)
	go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do
		mu <- liftAnnex $ probeGCryptRemoteUUID dir
		case mu of
			Just u -> enableexistinggcryptremote u
			Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
	enableexistinggcryptremote u = do
		remotename' <- liftAnnex $ getGCryptRemoteName u dir
		makewith $ const $ do
			r <- liftAnnex $ addRemote $
				enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
					[("gitrepo", dir)]
			return (u, r)
	{- Making a new unencrypted repo, or combining with an existing one. -}
	makeunencrypted = makewith $ \isnew -> (,)
		<$> liftIO (initRepo isnew False dir (Just remotename) Nothing)
		<*> combineRepos dir remotename
	makewith a = do
		liftIO $ createDirectoryIfMissing True dir
		isnew <- liftIO $ makeRepo dir True
		{- Removable drives are not reliable media, so enable fsync. -}
		liftIO $ inDir dir $
			setConfig (ConfigKey "core.fsyncobjectfiles")
				(Git.Config.boolConfig True)
		(u, r) <- a isnew
		when isnew $
			liftAnnex $ defaultStandardGroup u TransferGroup
		liftAssistant $ immediateSyncRemote r
		redirect $ EditNewRepositoryR u
  	mountpoint = T.unpack (mountPoint drive)
	dir = removableDriveRepository drive
	remotename = takeFileName mountpoint

{- Each repository is made a remote of the other.
 - Next call syncRemote to get them in sync. -}
combineRepos :: FilePath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do
	hostname <- fromMaybe "host" <$> liftIO getHostname
	hostlocation <- fromRepo Git.repoLocation
	liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
	addRemote $ makeGitRemote name dir

getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
	description <- liftAnnex $ T.pack <$> prettyUUID uuid
	$(widgetFile "configurators/enabledirectory")

{- List of removable drives. -}
driveList :: IO [RemovableDrive]
#ifdef mingw32_HOST_OS
-- Just enumerate all likely drive letters for Windows.
-- Could use wmic, but it only works for administrators.
driveList = mapM (\d -> genRemovableDrive $ d:":\\") ['A'..'Z']
#else
#ifdef WITH_CLIBS
driveList = mapM (genRemovableDrive . mnt_dir) =<< filter sane <$> getMounts
  where
	-- filter out some things that are surely not removable drives
	sane Mntent { mnt_dir = dir, mnt_fsname = dev }
		{- We want real disks like /dev/foo, not
		 - dummy mount points like proc or tmpfs or
		 - gvfs-fuse-daemon. -}
		| not ('/' `elem` dev) = False
		{- Just in case: These mount points are surely not
		 - removable disks. -}
		| dir == "/" = False
		| dir == "/tmp" = False
		| dir == "/run/shm" = False
		| dir == "/run/lock" = False
#ifdef __ANDROID__
		| dir == "/mnt/sdcard" = False
		| dir == "/sdcard" = False
#endif
		| otherwise = True
#else
driveList = return []
#endif
#endif

genRemovableDrive :: FilePath -> IO RemovableDrive
genRemovableDrive dir = RemovableDrive
	<$> getDiskFree dir
	<*> pure (T.pack dir)
	<*> pure (T.pack gitAnnexAssistantDefaultDir)

{- Bootstraps from first run mode to a fully running assistant in a
 - repository, by running the postFirstRun callback, which returns the
 - url to the new webapp. -}
startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
startFullAssistant path repogroup setup = do
	webapp <- getYesod
	url <- liftIO $ do
		isnew <- makeRepo path False
		void $ initRepo isnew True path Nothing (Just repogroup)
		inDir path $ fromMaybe noop setup
		addAutoStartFile path
		setCurrentDirectory path
		fromJust $ postFirstRun webapp
	redirect $ T.pack url

{- Checks if the user can write to a directory.
 -
 - The directory may be in the process of being created; if so
 - the parent directory is checked instead. -}
canWrite :: FilePath -> IO Bool
canWrite dir = do
	tocheck <- ifM (doesDirectoryExist dir)
		(return dir, return $ parentDir dir)
	catchBoolIO $ fileAccess tocheck False True False

{- Gets the UUID of the git repo at a location, which may not exist, or
 - not be a git-annex repo. -}
probeUUID :: FilePath -> IO (Maybe UUID)
probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
	u <- getUUID
	return $ if u == NoUUID then Nothing else Just u


code:
{- git-annex assistant webapp configurator for pairing
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Assistant.WebApp.Configurators.Pairing where

import Assistant.Pairing
import Assistant.WebApp.Common
import Assistant.Types.Buddies
import Annex.UUID
#ifdef WITH_PAIRING
import Assistant.Pairing.Network
import Assistant.Pairing.MakeRemote
import Assistant.Ssh
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
#endif
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.XMPP.Git
import Network.Protocol.XMPP
import Assistant.Types.NetMessager
import Assistant.NetMessager
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.XMPP
#endif
import Utility.UserInfo
import Git

import qualified Data.Text as T
#ifdef WITH_PAIRING
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as B
import Data.Char
import qualified Control.Exception as E
import Control.Concurrent
#endif
#ifdef WITH_XMPP
import qualified Data.Set as S
#endif

getStartXMPPPairFriendR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
	( do
		{- Ask buddies to send presence info, to get
		 - the buddy list populated. -}
		liftAssistant $ sendNetMessage QueryPresence
		pairPage $
			$(widgetFile "configurators/pairing/xmpp/friend/prompt")
	, do
		-- go get XMPP configured, then come back
		redirect XMPPConfigForPairFriendR
	)
#else
getStartXMPPPairFriendR = noXMPPPairing

noXMPPPairing :: Handler Html
noXMPPPairing = noPairing "XMPP"
#endif

getStartXMPPPairSelfR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
  where
  	go Nothing = do
		-- go get XMPP configured, then come back
		redirect XMPPConfigForPairSelfR
	go (Just creds) = do
		{- Ask buddies to send presence info, to get
		 - the buddy list populated. -}
		liftAssistant $ sendNetMessage QueryPresence
		let account = xmppJID creds
		pairPage $
			$(widgetFile "configurators/pairing/xmpp/self/prompt")
#else
getStartXMPPPairSelfR = noXMPPPairing
#endif

getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just

getRunningXMPPPairSelfR :: Handler Html
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing

{- Sends a XMPP pair request, to a buddy or to self. -}
sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
#ifdef WITH_XMPP
sendXMPPPairRequest mbid = do
	bid <- maybe getself return mbid
	buddy <- liftAssistant $ getBuddy bid <<~ buddyList
	go $ S.toList . buddyAssistants <$> buddy
  where
	go (Just (clients@((Client exemplar):_))) = do
		u <- liftAnnex getUUID
		liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
			PairingNotification PairReq (formatJID c) u
		xmppPairStatus True $
			if selfpair then Nothing else Just exemplar
	go _
		{- Nudge the user to turn on their other device. -}
		| selfpair = do
			liftAssistant $ sendNetMessage QueryPresence
			pairPage $
				$(widgetFile "configurators/pairing/xmpp/self/retry")
		{- Buddy could have logged out, etc.
		 - Go back to buddy list. -}
		| otherwise = redirect StartXMPPPairFriendR
	selfpair = isNothing mbid
	getself = maybe (error "XMPP not configured")
			(return . BuddyKey . xmppJID)
				=<< liftAnnex getXMPPCreds
#else
sendXMPPPairRequest _ = noXMPPPairing
#endif

{- Starts local pairing. -}
getStartLocalPairR :: Handler Html
getStartLocalPairR = postStartLocalPairR
postStartLocalPairR :: Handler Html
#ifdef WITH_PAIRING
postStartLocalPairR = promptSecret Nothing $
	startLocalPairing PairReq noop pairingAlert Nothing
#else
postStartLocalPairR = noLocalPairing

noLocalPairing :: Handler Html
noLocalPairing = noPairing "local"
#endif

{- Runs on the system that responds to a local pair request; sets up the ssh
 - authorized key first so that the originating host can immediately sync
 - with us. -}
getFinishLocalPairR :: PairMsg -> Handler Html
getFinishLocalPairR = postFinishLocalPairR
postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
	repodir <- liftH $ repoPath <$> liftAnnex gitRepo
	liftIO $ setup repodir
	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
  where
	alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
	setup repodir = setupAuthorizedKeys msg repodir
	cleanup repodir = removeAuthorizedKeys True repodir $
		remoteSshPubKey $ pairMsgData msg
	uuid = Just $ pairUUID $ pairMsgData msg
#else
postFinishLocalPairR _ = noLocalPairing
#endif

getConfirmXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
	Nothing -> error "bad JID"
	Just theirjid -> pairPage $ do
		let name = buddyName theirjid
		$(widgetFile "configurators/pairing/xmpp/friend/confirm")
#else
getConfirmXMPPPairFriendR _ = noXMPPPairing
#endif

getFinishXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
	Nothing -> error "bad JID"
	Just theirjid -> do
		selfuuid <- liftAnnex getUUID
		liftAssistant $ do
			sendNetMessage $
				PairingNotification PairAck (formatJID theirjid) selfuuid
			finishXMPPPairing theirjid theiruuid
		xmppPairStatus False $ Just theirjid
#else
getFinishXMPPPairFriendR _ = noXMPPPairing
#endif

{- Displays a page indicating pairing status and
 - prompting to set up cloud repositories. -}
#ifdef WITH_XMPP
xmppPairStatus :: Bool -> Maybe JID -> Handler Html
xmppPairStatus inprogress theirjid = pairPage $ do
	let friend = buddyName <$> theirjid
	$(widgetFile "configurators/pairing/xmpp/end")
#endif

getRunningLocalPairR :: SecretReminder -> Handler Html
#ifdef WITH_PAIRING
getRunningLocalPairR s = pairPage $ do
	let secret = fromSecretReminder s
	$(widgetFile "configurators/pairing/local/inprogress")
#else
getRunningLocalPairR _ = noLocalPairing
#endif

#ifdef WITH_PAIRING

{- Starts local pairing, at either the PairReq (initiating host) or
 - PairAck (responding host) stage.
 -
 - Displays an alert, and starts a thread sending the pairing message,
 - which will continue running until the other host responds, or until
 - canceled by the user. If canceled by the user, runs the oncancel action.
 -
 - Redirects to the pairing in progress page.
 -}
startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
startLocalPairing stage oncancel alert muuid displaysecret secret = do
	urlrender <- liftH getUrlRender
	reldir <- fromJust . relDir <$> liftH getYesod

	sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
	{- Generating a ssh key pair can take a while, so do it in the
	 - background. -}
	thread <- liftAssistant $ asIO $ do
		keypair <- liftIO $ genSshKeyPair
		pairdata <- liftIO $ PairData
			<$> getHostname
			<*> myUserName
			<*> pure reldir
			<*> pure (sshPubKey keypair)
			<*> (maybe genUUID return muuid)
		let sender = multicastPairMsg Nothing secret pairdata
		let pip = PairingInProgress secret Nothing keypair pairdata stage
		startSending pip stage $ sendrequests sender
	void $ liftIO $ forkIO thread

	liftH $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
  where
	{- Sends pairing messages until the thread is killed,
	 - and shows an activity alert while doing it.
	 -
	 - The cancel button returns the user to the DashboardR. This is
	 - not ideal, but they have to be sent somewhere, and could
	 - have been on a page specific to the in-process pairing
	 - that just stopped, so can't go back there.
	 -}
	mksendrequests urlrender sender _stage = do
		tid <- liftIO myThreadId
		let selfdestruct = AlertButton
			{ buttonLabel = "Cancel"
			, buttonPrimary = True
			, buttonUrl = urlrender DashboardR
			, buttonAction = Just $ const $ do
				oncancel
				killThread tid
			}
		alertDuring (alert selfdestruct) $ liftIO $ do
			_ <- E.try (sender stage) :: IO (Either E.SomeException ())
			return ()

data InputSecret = InputSecret { secretText :: Maybe Text }

{- If a PairMsg is passed in, ensures that the user enters a secret
 - that can validate it. -}
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
promptSecret msg cont = pairPage $ do
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
			InputSecret <$> aopt textField (bfs "Secret phrase") Nothing
	case result of
		FormSuccess v -> do
			let rawsecret = fromMaybe "" $ secretText v
			let secret = toSecret rawsecret
			case msg of
				Nothing -> case secretProblem secret of
					Nothing -> cont rawsecret secret
					Just problem ->
						showform form enctype $ Just problem
				Just m ->
					if verify (fromPairMsg m) secret
						then cont rawsecret secret
						else showform form enctype $ Just
							"That's not the right secret phrase."
		_ -> showform form enctype Nothing
  where
	showform form enctype mproblem = do
		let start = isNothing msg
		let badphrase = isJust mproblem
		let problem = fromMaybe "" mproblem
		let (username, hostname) = maybe ("", "")
			(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
			(verifiableVal . fromPairMsg <$> msg)
		u <- T.pack <$> liftIO myUserName
		let sameusername = username == u
		$(widgetFile "configurators/pairing/local/prompt")

{- This counts unicode characters as more than one character,
 - but that's ok; they *do* provide additional entropy. -}
secretProblem :: Secret -> Maybe Text
secretProblem s
	| B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)"
	| B.length s < 6 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day."
	| s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!"
	| otherwise = Nothing

toSecret :: Text -> Secret
toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s]

{- From Dickens -}
sampleQuote :: Text
sampleQuote = T.unwords
	[ "It was the best of times,"
	, "it was the worst of times,"
	, "it was the age of wisdom,"
	, "it was the age of foolishness."
	]

#else

#endif

pairPage :: Widget -> Handler Html
pairPage = page "Pairing" (Just Configuration)

noPairing :: Text -> Handler Html
noPairing pairingtype = pairPage $
	$(widgetFile "configurators/pairing/disabled")


code:
{- git-annex assistant general preferences
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Preferences (
	getPreferencesR,
	postPreferencesR
) where

import Assistant.WebApp.Common
import qualified Annex
import qualified Git
import Config
import Config.Files
import Config.NumCopies
import Utility.DataUnits
import Git.Config
import Types.Distribution
import qualified Build.SysConfig

import qualified Data.Text as T

data PrefsForm = PrefsForm
	{ diskReserve :: Text
	, numCopies :: Int
	, autoStart :: Bool
	, autoUpgrade :: AutoUpgrade
	, debugEnabled :: Bool
	}

prefsAForm :: PrefsForm -> MkAForm PrefsForm
prefsAForm def = PrefsForm
	<$> areq (storageField `withNote` diskreservenote)
		(bfs "Disk reserve") (Just $ diskReserve def)
	<*> areq (positiveIntField `withNote` numcopiesnote)
		(bfs "Number of copies") (Just $ numCopies def)
	<*> areq (checkBoxField `withNote` autostartnote)
		"Auto start" (Just $ autoStart def)
	<*> areq (selectFieldList autoUpgradeChoices)
		(bfs autoUpgradeLabel) (Just $ autoUpgrade def)
	<*> areq (checkBoxField `withNote` debugnote)
		"Enable debug logging" (Just $ debugEnabled def)
  where
	diskreservenote = [whamlet|
Avoid downloading files from other repositories when there is too little free disk space.|]
	numcopiesnote = [whamlet|
Only drop a file after verifying that other repositories contain this many copies.|]
	debugnote = [whamlet|View Log|]
	autostartnote = [whamlet|Start the git-annex assistant at boot or on login.|]

	autoUpgradeChoices :: [(Text, AutoUpgrade)]
	autoUpgradeChoices =
		[ ("ask me", AskUpgrade)
		, ("enabled", AutoUpgrade)
		, ("disabled", NoAutoUpgrade)
		]
	autoUpgradeLabel
		| isJust Build.SysConfig.upgradelocation = "Auto upgrade"
		| otherwise = "Auto restart on upgrade"

	positiveIntField = check isPositive intField
	  where
		isPositive i
			| i > 0 = Right i
			| otherwise = Left notPositive
		notPositive :: Text
		notPositive = "This should be 1 or more!"

	storageField = check validStorage textField
	  where
		validStorage t
			| T.null t = Right t
			| otherwise =  case readSize dataUnits $ T.unpack t of
				Nothing -> Left badParse
				Just _ -> Right t
		badParse :: Text
		badParse = "Parse error. Expected something like \"100 megabytes\" or \"2 gb\""

getPrefs :: Annex PrefsForm
getPrefs = PrefsForm
	<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
	<*> (fromNumCopies <$> getNumCopies)
	<*> inAutoStartFile
	<*> (annexAutoUpgrade <$> Annex.getGitConfig)
	<*> (annexDebug <$> Annex.getGitConfig)

storePrefs :: PrefsForm -> Annex ()
storePrefs p = do
	setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
	setGlobalNumCopies (NumCopies $ numCopies p)
	unsetConfig (annexConfig "numcopies") -- deprecated
	setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
	unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
		here <- fromRepo Git.repoPath
		liftIO $ if autoStart p
			then addAutoStartFile here
			else removeAutoStartFile here
	setConfig (annexConfig "debug") (boolConfig $ debugEnabled p)
	liftIO $ if debugEnabled p
		then enableDebugOutput
		else disableDebugOutput

getPreferencesR :: Handler Html
getPreferencesR = postPreferencesR
postPreferencesR :: Handler Html
postPreferencesR = page "Preferences" (Just Configuration) $ do
	((result, form), enctype) <- liftH $ do
		current <- liftAnnex getPrefs
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ prefsAForm current
	case result of
		FormSuccess new -> liftH $ do
			liftAnnex $ storePrefs new
			redirect ConfigurationR
		_ -> $(widgetFile "configurators/preferences")

inAutoStartFile :: Annex Bool
inAutoStartFile = do
	here <- fromRepo Git.repoPath
	any (`equalFilePath` here) <$> liftIO readAutoStartFile


code:
{- git-annex assistant webapp configurator for ssh-based remotes
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE CPP #-}

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
import Types.StandardGroups
import Utility.UserInfo
import Utility.Gpg
import Types.Remote (RemoteConfig)
import Git.Types (RemoteName)
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.Rsync
#endif

import qualified Data.Text as T
import qualified Data.Map as M
import Network.Socket
import Data.Ord

sshConfigurator :: Widget -> Handler Html
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
	}

data AuthMethod
	= Password
	| CachedPassword
	| ExistingSshKey
	deriving (Eq, Show)

-- Is a repository a new one that's being created, or did it already exist
-- and is just being added.
data RepoStatus = NewRepo | ExistingRepo

{- SshInput is only used for applicative form prompting, this converts
 - the result of such a form into a SshData. -}
mkSshData :: SshInput -> SshData
mkSshData s = SshData
	{ sshHostName = fromMaybe "" $ inputHostname s
	, sshUserName = inputUsername s
	, sshDirectory = fromMaybe "" $ inputDirectory s
	, sshRepoName = genSshRepoName
		(T.unpack $ fromJust $ inputHostname s)
		(maybe "" T.unpack $ inputDirectory s)
	, sshPort = inputPort s
	, needsPubKey = False
	, sshCapabilities = [] -- untested
	}

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
	}

#if MIN_VERSION_yesod(1,2,0)
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
#else
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
#endif
sshInputAForm hostnamefield def = normalize <$> gen
  where
	gen = SshInput
		<$> aopt check_hostname (bfs "Host name") (Just $ inputHostname def)
		<*> aopt check_username (bfs "User name") (Just $ inputUsername def)
		<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod 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)

	authmethods :: [(Text, AuthMethod)]
	authmethods =
		[ ("password", Password)
		, ("existing ssh key", ExistingSshKey)
		]

	check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
		bad_username textField

	bad_username = "bad user name" :: Text
#ifndef __ANDROID__
	bad_hostname = "cannot resolve host name" :: Text

	check_hostname = checkM (liftIO . checkdns) hostnamefield
	checkdns t = do
		let h = T.unpack t
		let canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
		r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
		return $ case mapMaybe addrCanonName <$> r of
			-- canonicalize input hostname if it had no dot
			Just (fullname:_)
				| '.' `elem` h -> Right t
				| otherwise -> Right $ T.pack fullname
			Just [] -> Right t
			Nothing -> Left bad_hostname
#else
	-- getAddrInfo currently broken on Android
	check_hostname = hostnamefield -- unchecked
#endif

	-- The directory is implicitly in home, so remove any leading ~/
	normalize i = i { inputDirectory = normalizedir <$> inputDirectory i }
	normalizedir d
		| "~/" `T.isPrefixOf` d = T.drop 2 d
		| "/~/" `T.isPrefixOf` d = T.drop 3 d
		| otherwise = d

data ServerStatus
	= UntestedServer
	| UnusableServer Text -- reason why it's not usable
	| UsableServer [SshServerCapability]
	deriving (Eq)

capabilities :: ServerStatus -> [SshServerCapability]
capabilities (UsableServer cs) = cs
capabilities _ = []

getAddSshR :: Handler Html
getAddSshR = postAddSshR
postAddSshR :: Handler Html
postAddSshR = sshConfigurator $ do
	username <- liftIO $ T.pack <$> myUserName
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $
			SshInput Nothing (Just username) Password Nothing Nothing 22
	case result of
		FormSuccess sshinput -> do
			s <- liftAssistant $ testServer sshinput
			case s of
				Left status -> showform form enctype status
				Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u
		_ -> showform form enctype UntestedServer
  where
	showform form enctype status = $(widgetFile "configurators/ssh/add")

sshTestModal :: Widget
sshTestModal = $(widgetFile "configurators/ssh/testmodal")

sshSetupModal :: SshData -> Widget
sshSetupModal sshdata = $(widgetFile "configurators/ssh/setupmodal")

getEnableRsyncR :: UUID -> Handler Html
getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler Html
postEnableRsyncR = enableSshRemote getsshinput enableRsyncNet enablersync
  where
	enablersync sshdata u = redirect $ ConfirmSshR
		(sshdata { sshCapabilities = [RsyncCapable] }) u
	getsshinput = parseSshUrl <=< M.lookup "rsyncurl"

{- This only handles gcrypt repositories that are located on ssh servers;
 - ones on local drives are handled via another part of the UI. -}
getEnableSshGCryptR :: UUID -> Handler Html
getEnableSshGCryptR = postEnableSshGCryptR
postEnableSshGCryptR :: UUID -> Handler Html
postEnableSshGCryptR u = whenGcryptInstalled $
	enableSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
  where
  	enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
		sshConfigurator $
			checkExistingGCrypt sshdata' $
				error "Expected to find an encrypted git repository, but did not."
	getsshinput = parseSshUrl <=< M.lookup "gitrepo"

getEnableSshGitRemoteR :: UUID -> Handler Html
getEnableSshGitRemoteR = postEnableSshGitRemoteR
postEnableSshGitRemoteR :: UUID -> Handler Html
postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgitremote
  where
	enablesshgitremote sshdata u = redirect $ ConfirmSshR sshdata u

	getsshinput = parseSshUrl <=< M.lookup "location"

{- To enable a remote that uses ssh as its transport,
 - parse a config key to get its url, and display a form
 - to prompt for its password.
 -}
enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html
enableSshRemote getsshinput rsyncnetsetup genericsetup u = do
	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
	case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
		(Just sshinput, Just reponame) -> sshConfigurator $ do
			((result, form), enctype) <- liftH $
				runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField sshinput
			case result of
				FormSuccess sshinput'
					| isRsyncNet (inputHostname sshinput') ->
						void $ liftH $ rsyncnetsetup sshinput' reponame
					| otherwise -> do
						s <- liftAssistant $ testServer sshinput'
						case s of
							Left status -> showform form enctype status
							Right (sshdata, _u) -> void $ liftH $ genericsetup
								( sshdata { sshRepoName = reponame } ) u
				_ -> showform form enctype UntestedServer
		_ -> redirect AddSshR
  where
  	unmangle sshdata = sshdata
		{ sshHostName = T.pack $ unMangleSshHostName $
			T.unpack $ sshHostName sshdata
		}
	showform form enctype status = do
		description <- liftAnnex $ T.pack <$> prettyUUID u
		$(widgetFile "configurators/ssh/enable")

{- To deal with git-annex and possibly even git and rsync not being
 - available in the remote server's PATH, when git-annex was installed
 - from the standalone tarball etc, look for a ~/.ssh/git-annex-wrapper
 - and if it's there, use it to run a command. -}
wrapCommand :: String -> String
wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper ++ " " ++ cmd ++ "; else " ++ cmd ++ "; fi"

commandWrapper :: String
commandWrapper = "~/.ssh/git-annex-wrapper"

{- Test if we can ssh into the server, using the specified AuthMethod.
 -
 - 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 present, while
 - 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 -> 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
	case capabilities status of
		[] -> return $ Left status
		cs -> do
			let sshdata = (mkSshData sshinput)
				{ needsPubKey = inputAuthMethod sshinput /= ExistingSshKey
				, sshCapabilities = cs
				}
			return $ Right (sshdata, u)
  where
	probe = do
		let remotecommand = shellWrap $ intercalate ";"
			[ report "loggedin"
			, checkcommand "git-annex-shell"
			, checkcommand "git"
			, checkcommand "rsync"
			, checkcommand shim
			, checkcommand commandWrapper
			, getgitconfig (T.unpack <$> inputDirectory sshinput)
			]
		knownhost <- liftIO $ knownHost hn
		let sshopts =
			{- If this is an already known host, let
			 - ssh check it as usual.
			 - Otherwise, trust the host key. -}
			[ sshOpt "StrictHostKeyChecking" $
				if knownhost then "yes" else "no"
			, "-n" -- don't read from stdin
			, "-p", show (inputPort sshinput)
			, genSshHost
				(fromJust $ inputHostname sshinput)
				(inputUsername sshinput)
			, remotecommand
			]
		parsetranscript . fst <$> sshAuthTranscript sshinput sshopts Nothing
	parsetranscript s =
		let cs = map snd $ filter (reported . fst)
			[ ("git-annex-shell", GitAnnexShellCapable)
			, (shim, GitAnnexShellCapable)
			, ("git", GitCapable)
			, ("rsync", RsyncCapable)
			, (commandWrapper, GitCapable)
			, (commandWrapper, RsyncCapable)
			]
		    u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
			map (separate (== '=')) $ lines s
		in if null cs
			then (UnusableServer unusablereason, u)
			else (UsableServer cs, u)
	  where
		reported r = token r `isInfixOf` s
		unusablereason = if reported "loggedin"
				then "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
				else T.pack $ "Failed to ssh to the server. Transcript: " ++ s
		finduuid (k, v)
			| k == "annex.uuid" = Just $ toUUID v
			| k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v
			| otherwise = Nothing

	checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
	token r = "git-annex-probe " ++ r
	report r = "echo " ++ shellEscape (token r)
	shim = "~/.ssh/git-annex-shell"
	getgitconfig (Just d)
		| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
	getgitconfig _ = "echo"

{- Runs a ssh command to set up the repository; if it fails shows
 - the user the transcript, and if it succeeds, runs an action. -}
sshSetup :: SshInput -> [String] -> Maybe String -> Handler Html -> Handler Html
sshSetup sshinput opts input a = do
	(transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts input
	if ok
		then do
			liftAssistant $ expireCachedCred $ getLogin sshinput
			a
		else sshErr sshinput transcript

sshErr :: SshInput -> String -> Handler Html
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 environ = processTranscript' "ssh" (extraopts ++ opts) environ $
		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
				environ <- getEnvironment
				let environ' = addEntries
					[ ("SSH_ASKPASS", program)
					, (sshAskPassEnv, passfile)
					-- ssh does not use SSH_ASKPASS
					-- unless DISPLAY is set, and
					-- there is no controlling
					-- terminal.
					, ("DISPLAY", ":0")
					] environ
				go [passwordprompts 1] (Just environ')

	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
getConfirmSshR sshdata u
	| u == NoUUID = handlenew
	| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap)
  where
	handlenew = sshConfigurator $ do
		secretkeys <- sortBy (comparing snd) . M.toList
			<$> liftIO secretKeys
		$(widgetFile "configurators/ssh/confirm")
  	handleexisting Nothing = sshConfigurator $
		-- Not a UUID we know, so prompt about combining.
		$(widgetFile "configurators/ssh/combine")
	handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do
		m <- liftAnnex readRemoteLog
		case M.lookup "type" =<< M.lookup u m of
			Just "gcrypt" -> combineExistingGCrypt sshdata' u
			_ -> makeSshRepo ExistingRepo sshdata'

{- The user has confirmed they want to combine with a ssh repository,
 - which is not known to us. So it might be using gcrypt. -}
getCombineSshR :: SshData -> Handler Html
getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->
	sshConfigurator $
		checkExistingGCrypt sshdata' $
			void $ liftH $ makeSshRepo ExistingRepo sshdata'

getRetrySshR :: SshData -> Handler ()
getRetrySshR sshdata = do
	s <- liftAssistant $ testServer $ mkSshInput sshdata
	redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s

{- Making a new git repository. -}
getMakeSshGitR :: SshData -> Handler Html
getMakeSshGitR sshdata = prepSsh True sshdata (makeSshRepo NewRepo)

getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) (makeSshRepo NewRepo)

rsyncOnly :: SshData -> SshData
rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }

getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
	withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
	prepSsh False sshdata $ makeGCryptRepo NewRepo keyid

{- Detect if the user entered a location with an existing, known
 - gcrypt repository, and enable it. Otherwise, runs the action. -}
checkExistingGCrypt :: SshData -> Widget -> Widget
checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $ do
	mu <- liftAnnex $ probeGCryptRemoteUUID repourl
	case mu of
		Just u -> void $ liftH $
			combineExistingGCrypt sshdata u
		Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
  where
  	repourl = genSshUrl sshdata

{- Enables an existing gcrypt special remote. -}
enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame = setupRemote postsetup Nothing Nothing mk
  where
	mk = enableSpecialRemote reponame GCrypt.remote Nothing $
		M.fromList [("gitrepo", genSshUrl sshdata)]
	postsetup _ = redirect DashboardR

{- Combining with a gcrypt repository that may not be
 - known in remote.log, so probe the gcrypt repo. -}
combineExistingGCrypt :: SshData -> UUID -> Handler Html
combineExistingGCrypt sshdata u = do
	reponame <- liftAnnex $ getGCryptRemoteName u repourl
	enableGCrypt sshdata reponame
  where
  	repourl = genSshUrl sshdata

{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
prepSsh needsinit sshdata a
	| needsPubKey sshdata = do
		keypair <- liftIO genSshKeyPair
		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
		prepSsh' needsinit sshdata sshdata' (Just keypair) a
	| sshPort sshdata /= 22 = do
		sshdata' <- liftIO $ setSshConfig sshdata []
		prepSsh' needsinit sshdata sshdata' Nothing 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 (mkSshInput origsshdata)
	 [ "-p", show (sshPort origsshdata)
	 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
	 , remoteCommand
	 ] Nothing (a sshdata)
  where
	remotedir = T.unpack $ sshDirectory sshdata
	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
		[ Just $ "mkdir -p " ++ shellEscape remotedir
		, Just $ "cd " ++ shellEscape remotedir
		, if rsynconly then Nothing else Just $ unwords
			[ "if [ ! -d .git ]; then"
			, wrapCommand "git init --bare --shared"
		, "&&"
			, wrapCommand "git config receive.denyNonFastforwards"
			, ";fi"
			]
		, if needsinit then Just (wrapCommand "git annex init") else Nothing
		, if needsPubKey origsshdata
			then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
			else Nothing
		]
	rsynconly = onlyCapability origsshdata RsyncCapable

makeSshRepo :: RepoStatus -> SshData -> Handler Html
makeSshRepo rs sshdata
	| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing mk
	| otherwise = makeSshRepoConnection rs mk setup
  where
	mk = makeSshRemote sshdata
	-- Record the location of the ssh remote in the remote log, so it
	-- can easily be enabled elsewhere using the webapp.
	setup r = do
		m <- readRemoteLog
		let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m)
		let c' = M.insert "location" (genSshUrl sshdata) $
			M.insert "type" "git" $
			M.insert "name" (fromMaybe (Remote.name r) (M.lookup "name" c)) c
		configSet (Remote.uuid r) c'

makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html
makeSshRepoConnection rs mk setup = setupRemote postsetup mgroup Nothing mk
  where
	mgroup = case rs of
		NewRepo -> Just TransferGroup
		ExistingRepo -> Nothing
	postsetup r = do
		liftAssistant $ sendRemoteControl RELOAD
		liftAnnex $ setup r
		case rs of
			NewRepo -> redirect $ EditNewRepositoryR (Remote.uuid r)
			ExistingRepo -> redirect DashboardR

makeGCryptRepo :: RepoStatus -> KeyId -> SshData -> Handler Html
makeGCryptRepo rs keyid sshdata = makeSshRepoConnection rs mk (const noop)
  where
	mk = makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid

getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler Html
postAddRsyncNetR = do
	((result, form), enctype) <- runFormPostNoToken $
		renderBootstrap3 bootstrapFormLayout $ sshInputAForm hostnamefield $
			SshInput Nothing Nothing Password Nothing Nothing 22
	let showform status = inpage $
		$(widgetFile "configurators/rsync.net/add")
	case result of
		FormSuccess sshinput
			| isRsyncNet (inputHostname sshinput) ->
				go sshinput
			| otherwise ->
				showform $ UnusableServer
					"That is not a rsync.net host name."
		_ -> showform UntestedServer
  where
  	inpage = page "Add a Rsync.net repository" (Just Configuration)
	hostnamefield = textField `withExpandableNote` ("Help", help)
	help = [whamlet|
<div>
  When you sign up for a Rsync.net account, you should receive an #
  email from them with the host name and user name to put here.
<div>
  The host name will be something like "usw-s001.rsync.net", and the #
  user name something like "7491"
|]
	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
					<$> liftIO secretKeys
				$(widgetFile "configurators/rsync.net/encrypt")

getMakeRsyncNetSharedR :: SshData -> Handler Html
getMakeRsyncNetSharedR = makeSshRepo NewRepo . rsyncOnly

{- Make a new gcrypt special remote on rsync.net. -}
getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
	sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $
		makeGCryptRepo NewRepo keyid sshdata
  where
	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)

enableRsyncNet :: SshInput -> String -> Handler Html
enableRsyncNet sshinput reponame =
	prepRsyncNet sshinput reponame $ makeSshRepo ExistingRepo . rsyncOnly

enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
enableRsyncNetGCrypt sshinput reponame =
	prepRsyncNet sshinput reponame $ \sshdata -> whenGcryptInstalled $
		checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
			enableGCrypt sshdata reponame
  where
	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
	notinstalled = error "internal"

{- Prepares rsync.net ssh key and creates the directory that will be
 - used on rsync.net. If successful, runs an action with its SshData.
 -
 - 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.
 -}
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
prepRsyncNet sshinput reponame a = do
	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
	keypair <- liftIO genSshKeyPair
	sshdata <- liftIO $ setupSshKeyPair keypair $
		(mkSshData sshinput)
			{ sshRepoName = reponame
			, needsPubKey = True
			, sshCapabilities = [RsyncCapable]
			}
	let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
	let torsyncnet cmd = filter (not . null)
		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
		, sshhost
		, cmd
		]
	{- I'd prefer to separate commands with && , but
	 - rsync.net's shell does not support that. -}
	let remotecommand = intercalate ";"
		[ "mkdir -p .ssh"
		, "touch .ssh/authorized_keys"
		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
		]
	sshSetup sshinput (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)

isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host


code:
{- git-annex assistant unused file preferences
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Unused where

import Assistant.WebApp.Common
import qualified Annex
import Utility.HumanTime
import Assistant.Unused
import Config
import Git.Config
import Logs.Unused
import Utility.Tense

import qualified Text.Hamlet as Hamlet

data UnusedForm = UnusedForm
	{ enableExpire :: Bool
	, expireWhen :: Integer
	}

unusedForm :: UnusedForm -> Hamlet.Html -> MkMForm UnusedForm
unusedForm def msg = do
	(enableRes, enableView) <- mreq (selectFieldList enabledisable) (bfs "")
		(Just $ enableExpire def)
	(whenRes, whenView) <- mreq intField (bfs "")
		(Just $ expireWhen def)
	let form = do
		webAppFormAuthToken
		$(widgetFile "configurators/unused/form")
	return (UnusedForm <$> enableRes <*> whenRes, form)
  where
	enabledisable :: [(Text, Bool)]
	enabledisable = [("Disable expiry", False), ("Enable expiry", True)]

getConfigUnusedR :: Handler Html
getConfigUnusedR = postConfigUnusedR
postConfigUnusedR :: Handler Html
postConfigUnusedR = page "Unused files" (Just Configuration) $ do
	current <- liftAnnex getUnused
	((res, form), enctype) <- liftH $ runFormPostNoToken $ unusedForm current
	case res of
		FormSuccess new -> liftH $ do
			liftAnnex $ storeUnused new
			redirect ConfigurationR
		_ -> do
			munuseddesc <- liftAssistant describeUnused
			ts <- liftAnnex $ dateUnusedLog ""
			mlastchecked <- case ts of
				Nothing -> pure Nothing
				Just t -> Just <$> liftIO (durationSince t)
			$(widgetFile "configurators/unused")

getUnused :: Annex UnusedForm
getUnused = convert . annexExpireUnused <$> Annex.getGitConfig
  where
	convert Nothing = noexpire
	convert (Just Nothing) = noexpire
	convert (Just (Just n)) = UnusedForm True $ durationToDays n

	-- The 7 is so that, if they enable expiry, they have to change
	-- it to get faster than  a week.
	noexpire = UnusedForm False 7

storeUnused :: UnusedForm -> Annex ()
storeUnused f = setConfig (annexConfig "expireunused") $
	if not (enableExpire f) || expireWhen f < 0
		then boolConfig False
		else fromDuration $ daysToDuration $ expireWhen f

getCleanupUnusedR :: Handler Html
getCleanupUnusedR = do
	liftAssistant $ expireUnused Nothing
	redirect ConfigUnusedR


code:
{- git-annex assistant webapp upgrade UI
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.WebApp.Configurators.Upgrade where

import Assistant.WebApp.Common
import Types.Distribution
import Assistant.Upgrade
import Assistant.Restart
import Config

{- On Android, just point the user at the apk file to download.
 - Installation will be handled by selecting the downloaded file.
 -
 - Otherwise, start the upgrade process, which will run fully
 - noninteractively.
 - -}
getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html
getConfigStartUpgradeR d = do
#ifdef ANDROID_SPLICES
	let url = distributionUrl d
	page "Upgrade" (Just Configuration) $
		$(widgetFile "configurators/upgrade/android")
#else
	liftAssistant $ startDistributionDownload d
	redirect DashboardR
#endif

{- Finish upgrade by starting the new assistant in the same repository this
 - one is running in, and redirecting to it. -}
getConfigFinishUpgradeR :: Handler Html
getConfigFinishUpgradeR = do
	liftAssistant prepUpgrade
	url <- liftAssistant runRestart
	liftAssistant $ postUpgrade url
	redirect url

getConfigEnableAutomaticUpgradeR :: Handler Html
getConfigEnableAutomaticUpgradeR = do
	liftAnnex $ setConfig (annexConfig "autoupgrade")
		(fromAutoUpgrade AutoUpgrade)
	redirect DashboardR