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

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

module Assistant.WebApp.Configurators.WebDAV where

import Assistant.WebApp.Common
import Creds
#ifdef WITH_WEBDAV
import qualified Remote.WebDAV as WebDAV
import Assistant.WebApp.MakeRemote
import qualified Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Logs.Remote
import Git.Types (RemoteName)

import qualified Data.Map as M
#endif
import qualified Data.Text as T
import Network.URI
import Assistant.Gpg

webDAVConfigurator :: Widget -> Handler Html
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)

boxConfigurator :: Widget -> Handler Html
boxConfigurator = page "Add a Box.com repository" (Just Configuration)

data WebDAVInput = WebDAVInput
	{ user :: Text
	, password :: Text
	, embedCreds :: Bool
	, directory :: Text
	, enableEncryption :: EnableEncryption
	}

toCredPair :: WebDAVInput -> CredPair
toCredPair input = (T.unpack $ user input, T.unpack $ password input)

boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
boxComAForm defcreds = WebDAVInput
	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
	<*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds)
	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
	<*> areq textField (bfs "Directory") (Just "annex")
	<*> enableEncryptionField

webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
webDAVCredsAForm defcreds = WebDAVInput
	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
	<*> areq passwordField (bfs "Password") (T.pack . snd <$> defcreds)
	<*> pure False
	<*> pure T.empty
	<*> pure NoEncryption -- not used!

getAddBoxComR :: Handler Html
getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler Html
#ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do
	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
	((result, form), enctype) <- liftH $
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout
			$ boxComAForm defcreds
	case result of
		FormSuccess input -> liftH $
			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
				[ configureEncryption $ enableEncryption input
				, ("embedcreds", if embedCreds input then "yes" else "no")
				, ("type", "webdav")
				, ("url", "https://dav.box.com/dav/" ++ T.unpack (directory input))
				-- Box.com has a max file size of 100 mb, but
				-- using smaller chunks has better memory
				-- performance.
				, ("chunksize", "10mb")
				]
		_ -> $(widgetFile "configurators/addbox.com")
#else
postAddBoxComR = error "WebDAV not supported by this build"
#endif

getEnableWebDAVR :: UUID -> Handler Html
getEnableWebDAVR = postEnableWebDAVR
postEnableWebDAVR :: UUID -> Handler Html
#ifdef WITH_WEBDAV
postEnableWebDAVR uuid = do
	m <- liftAnnex readRemoteLog
	let c = fromJust $ M.lookup uuid m
	let name = fromJust $ M.lookup "name" c
	let url = fromJust $ M.lookup "url" c
	mcreds <- liftAnnex $
		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
	case mcreds of
		Just creds -> webDAVConfigurator $ liftH $
			makeWebDavRemote enableSpecialRemote name creds M.empty
		Nothing
			| "box.com/" `isInfixOf` url ->
				boxConfigurator $ showform name url
			| otherwise ->
				webDAVConfigurator $ showform name url
  where
	showform name url = do
		defcreds <- liftAnnex $
			maybe (pure Nothing) previouslyUsedWebDAVCreds $
				urlHost url
		((result, form), enctype) <- liftH $
			runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
				webDAVCredsAForm defcreds
		case result of
			FormSuccess input -> liftH $
				makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty
			_ -> do
				description <- liftAnnex $
					T.pack <$> Remote.prettyUUID uuid
				$(widgetFile "configurators/enablewebdav")
#else
postEnableWebDAVR _ = error "WebDAV not supported by this build"
#endif

#ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config =
	setupCloudRemote TransferGroup Nothing $
		maker name WebDAV.remote (Just creds) config

{- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
previouslyUsedWebDAVCreds hostname =
	previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
  where
	samehost url = case urlHost =<< WebDAV.configUrl url of
		Nothing -> False
		Just h -> h == hostname
#endif

urlHost :: String -> Maybe String
urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)


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

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

module Assistant.WebApp.Configurators.XMPP where

import Assistant.WebApp.Common
import Assistant.WebApp.Notifications
import Utility.NotificationBroadcaster
#ifdef WITH_XMPP
import qualified Remote
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.Types.Buddies
import Assistant.NetMessager
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
import qualified Git.Remote
import Remote.List
import Creds

#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Network
import qualified Data.Text as T
#endif

{- When appropriate, displays an alert suggesting to configure a cloud repo
 - to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
#ifdef WITH_XMPP
checkCloudRepos urlrenderer r =
	unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
		buddyname <- getBuddyName $ Remote.uuid r
		button <- mkAlertButton True "Add a cloud repository" urlrenderer $
			NeedCloudRepoR $ Remote.uuid r
		void $ addAlert $ cloudRepoNeededAlert buddyname button
#else
checkCloudRepos _ _ = noop
#endif

#ifdef WITH_XMPP
{- Returns the name of the friend corresponding to a
 - repository's UUID, but not if it's our name. -}
getBuddyName :: UUID -> Assistant (Maybe String)
getBuddyName u = go =<< getclientjid
  where
	go Nothing = return Nothing
	go (Just myjid) = (T.unpack . buddyName <$>)
		. headMaybe
		. filter (\j -> baseJID j /= baseJID myjid)
		. map fst
		. filter (\(_, r) -> Remote.uuid r == u)
		<$> getXMPPRemotes
	getclientjid = maybe Nothing parseJID . xmppClientID
		<$> getDaemonStatus
#endif

getNeedCloudRepoR :: UUID -> Handler Html
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
	buddyname <- liftAssistant $ getBuddyName for
	$(widgetFile "configurators/xmpp/needcloudrepo")
#else
getNeedCloudRepoR _ = xmppPage $
	$(widgetFile "configurators/xmpp/disabled")
#endif

getXMPPConfigR :: Handler Html
getXMPPConfigR = postXMPPConfigR

postXMPPConfigR :: Handler Html
postXMPPConfigR = xmppform DashboardR

getXMPPConfigForPairFriendR :: Handler Html
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR

postXMPPConfigForPairFriendR :: Handler Html
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR

getXMPPConfigForPairSelfR :: Handler Html
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR

postXMPPConfigForPairSelfR :: Handler Html
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR

xmppform :: Route WebApp -> Handler Html
#ifdef WITH_XMPP
xmppform next = xmppPage $ do
	((result, form), enctype) <- liftH $ do
		oldcreds <- liftAnnex getXMPPCreds
		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
			creds2Form <$> oldcreds
	let showform problem = $(widgetFile "configurators/xmpp")
	case result of
		FormSuccess f -> either (showform . Just) (liftH . storecreds)
			=<< liftIO (validateForm f)
		_ -> showform Nothing
  where
	storecreds creds = do
		void $ liftAnnex $ setXMPPCreds creds
		liftAssistant notifyNetMessagerRestart
		redirect next
#else
xmppform _ = xmppPage $
	$(widgetFile "configurators/xmpp/disabled")
#endif

{- Called by client to get a list of buddies.
 -
 - Returns a div, which will be inserted into the calling page.
 -}
getBuddyListR :: NotificationId -> Handler Html
getBuddyListR nid = do
	waitNotifier getBuddyListBroadcaster nid

	p <- widgetToPageContent buddyListDisplay
	giveUrlRenderer $ [hamlet|^{pageBody p}|]

buddyListDisplay :: Widget
buddyListDisplay = do
	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
	myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
	let isself (BuddyKey b) = Just b == myjid
	buddies <- liftAssistant $ do
		pairedwith <- map fst <$> getXMPPRemotes
		catMaybes . map (buddySummary pairedwith)
			<$> (getBuddyList <<~ buddyList)
	$(widgetFile "configurators/xmpp/buddylist")
#else
	noop
#endif
  where
	ident = "buddylist"

#ifdef WITH_XMPP

getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
	<$> getDaemonStatus
  where
  	pair r = maybe Nothing (\jid -> Just (jid, r)) $
		parseJID $ getXMPPClientID r

data XMPPForm = XMPPForm
	{ formJID :: Text
	, formPassword :: Text }

creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)

xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
xmppAForm def = XMPPForm
	<$> areq jidField (bfs "Jabber address") (formJID <$> def)
	<*> areq passwordField (bfs "Password") Nothing

jidField :: MkField Text
jidField = checkBool (isJust . parseJID) bad textField
  where
	bad :: Text
	bad = "This should look like an email address.."

validateForm :: XMPPForm -> IO (Either String XMPPCreds)
validateForm f = do
	let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
	let username = fromMaybe "" (strNode <$> jidNode jid)
	testXMPP $ XMPPCreds
		{ xmppUsername = username
		, xmppPassword = formPassword f
		, xmppHostname = T.unpack $ strDomain $ jidDomain jid
		, xmppPort = 5222
		, xmppJID = formJID f
		}

testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
testXMPP creds = do
	(good, bad) <- partition (either (const False) (const True) . snd)
		<$> connectXMPP creds (const noop)
	case good of
		(((h, PortNumber p), _):_) -> return $ Right $ creds
			{ xmppHostname = h
			, xmppPort = fromIntegral p
			}
		(((h, _), _):_) -> return $ Right $ creds
			{ xmppHostname = h
			}
		_ -> return $ Left $ intercalate "; " $ map formatlog bad
  where
  	formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
  	formatlog _ = ""

	showport (PortNumber n) = show n
	showport (Service s) = s
	showport (UnixSocket s) = s
#endif

getDisconnectXMPPR :: Handler Html
getDisconnectXMPPR = do
#ifdef WITH_XMPP
	rs <- filter Remote.isXMPPRemote . syncRemotes
		<$> liftAssistant getDaemonStatus
	liftAnnex $ do
		mapM_ (inRepo . Git.Remote.remove . Remote.name) rs
		void remoteListRefresh
		removeCreds xmppCredsFile
	liftAssistant $ do
		updateSyncRemotes
		notifyNetMessagerRestart
	redirect DashboardR
#else
	xmppPage $ $(widgetFile "configurators/xmpp/disabled")
#endif

xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)

repo_name: kakafarm/git

license: unknown


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

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

module Assistant.WebApp.Control where

import Assistant.WebApp.Common
import Assistant.DaemonStatus
import Assistant.Alert
import Assistant.TransferSlots
import Assistant.Restart
import Utility.LogFile
import Utility.NotificationBroadcaster
import Utility.PID

import Control.Concurrent
import qualified Data.Map as M
import qualified Data.Text as T
#ifndef mingw32_HOST_OS
import System.Posix (signalProcess, sigTERM)
#else
import Utility.WinProcess
#endif

getShutdownR :: Handler Html
getShutdownR = page "Shutdown" Nothing $
	$(widgetFile "control/shutdown")

getShutdownConfirmedR :: Handler Html
getShutdownConfirmedR = do
	liftAssistant $ do
		{- Remove all alerts for currently running activities. -}
		updateAlertMap $ M.filter $ \a -> alertClass a /= Activity
		void $ addAlert shutdownAlert
		{- Stop transfers the assistant is running,
		 - otherwise they would continue past shutdown.
		 - Pausing transfers prevents more being started up (and stops
		 - the transfer processes). -}
		ts <- M.keys . currentTransfers <$> getDaemonStatus
		mapM_ pauseTransfer ts
	webapp <- getYesod
	let url = T.unpack $ yesodRender webapp (T.pack "") NotRunningR []
	{- Signal any other web browsers. -}
	liftAssistant $ do
		modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
		liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
	{- Wait 2 seconds before shutting down, to give the web
	 - page time to load in the browser. -}
	void $ liftIO $ forkIO $ do
		threadDelay 2000000
#ifndef mingw32_HOST_OS
		signalProcess sigTERM =<< getPID
#else
		terminatePID =<< getPID
#endif
	redirect NotRunningR

{- Use a custom page to avoid putting long polling elements on it that will
 - fail and cause the web browser to show an error once the webapp is
 - truely stopped. -}
getNotRunningR :: Handler Html
getNotRunningR = customPage' False Nothing $
	$(widgetFile "control/notrunning")

getRestartR :: Handler Html
getRestartR = do
	liftAssistant prepRestart
	url <- liftAssistant runRestart
	liftAssistant $ postRestart url
	redirect url

getRestartThreadR :: ThreadName -> Handler ()
getRestartThreadR name = do
	m <- liftAssistant $ startedThreads <$> getDaemonStatus
	liftIO $ maybe noop snd $ M.lookup name m
	redirectBack

getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
	logfile <- liftAnnex $ fromRepo gitAnnexLogFile
	logs <- liftIO $ listLogs logfile
	logcontent <- liftIO $ concat <$> mapM readFileStrictAnyEncoding logs
	$(widgetFile "control/log")


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

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

module Assistant.WebApp.DashBoard where

import Assistant.WebApp.Common
import Assistant.WebApp.RepoList
import Assistant.WebApp.Notifications
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Logs.Transfer
import Utility.Percentage
import Utility.DataUnits
import Types.Key
import qualified Remote
import qualified Git

import qualified Text.Hamlet as Hamlet
import qualified Data.Map as M
import Control.Concurrent

{- A display of currently running and queued transfers. -}
transfersDisplay :: Widget
transfersDisplay = do
	current <- liftAssistant $ M.toList <$> getCurrentTransfers
	queued <- take 10 <$> liftAssistant getTransferQueue
	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
	let transfers = simplifyTransfers $ current ++ queued
	let transfersrunning = not $ null transfers
	scanrunning <- if transfersrunning
		then return False
		else liftAssistant $ transferScanRunning <$> getDaemonStatus
	$(widgetFile "dashboard/transfers")
  where
	ident = "transfers"
	isrunning info = not $
		transferPaused info || isNothing (startedTime info)

{- Simplifies a list of transfers, avoiding display of redundant
 - equivilant transfers. -}
simplifyTransfers :: [(Transfer, TransferInfo)] -> [(Transfer, TransferInfo)]
simplifyTransfers [] = []
simplifyTransfers (x:[]) = [x]
simplifyTransfers (v@(t1, _):r@((t2, _):l))
	| equivilantTransfer t1 t2 = simplifyTransfers (v:l)
	| otherwise = v : simplifyTransfers r

{- Called by client to get a display of currently in process transfers.
 -
 - Returns a div, which will be inserted into the calling page.
 -
 - Note that the head of the widget is not included, only its
 - body is. To get the widget head content, the widget is also
 - inserted onto the getDashboardR page.
 -}
getTransfersR :: NotificationId -> Handler Html
getTransfersR nid = do
	waitNotifier getTransferBroadcaster nid

	p <- widgetToPageContent transfersDisplay
	giveUrlRenderer $ [hamlet|^{pageBody p}|]

{- The main dashboard. -}
dashboard :: Bool -> Widget
dashboard warnNoScript = do
	let repolist = repoListDisplay $
		mainRepoSelector { nudgeAddMore = True }
	let transferlist = transfersDisplay
	$(widgetFile "dashboard/main")

getDashboardR :: Handler Html
getDashboardR = ifM inFirstRun
	( redirect ConfigurationR
	, page "" (Just DashBoard) $ dashboard True
	)

{- Used to test if the webapp is running. -}
headDashboardR :: Handler ()
headDashboardR = noop

{- Same as DashboardR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler Html
getNoScriptR = page "" (Just DashBoard) $ dashboard False

{- Same as DashboardR, except with autorefreshing via meta refresh. -}
getNoScriptAutoR :: Handler Html
getNoScriptAutoR = page "" (Just DashBoard) $ do
	let delayseconds = 3 :: Int
	let this = NoScriptAutoR
	toWidgetHead $(Hamlet.hamletFile $ hamletTemplate "dashboard/metarefresh")
	dashboard False

{- The javascript code does a post. -}
postFileBrowserR :: Handler ()
postFileBrowserR = void openFileBrowser

{- Used by non-javascript browsers, where clicking on the link actually
 - opens this page, so we redirect back to the referrer. -}
getFileBrowserR :: Handler ()
getFileBrowserR = whenM openFileBrowser redirectBack

{- Opens the system file browser on the repo, or, as a fallback,
 - goes to a file:// url. Returns True if it's ok to redirect away
 - from the page (ie, the system file browser was opened).
 -
 - Note that the command is opened using a different thread, to avoid
 - blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool
openFileBrowser = do
	path <- liftAnnex $ fromRepo Git.repoPath
#ifdef darwin_HOST_OS
	let cmd = "open"
	let p = proc cmd [path]
#else
#ifdef mingw32_HOST_OS
	{- Changing to the directory and then opening . works around
	 - spaces in directory name, etc. -}
	let cmd = "cmd"
	let p = (proc cmd ["/c start ."]) { cwd = Just path }
#else
	let cmd = "xdg-open"
	let p = proc cmd [path]
#endif
#endif
	ifM (liftIO $ inPath cmd)
		( do
			let run = void $ liftIO $ forkIO $ void $
				createProcess p
			run
#ifdef mingw32_HOST_OS
			{- On windows, if the file browser is not
			 - already open, it comes up below the
			 - web browser when started.
			 -
			 - Running it a second time brings it
			 - to the foreground.
			 -
			 - Seems to need a delay long enough for the file
			 - browser to be open in order to work. Here 1
			 - second. -}
			liftIO $ threadDelay 1000000
			run
#endif
			return True
		, do
			void $ redirect $ "file://" ++ path
			return False
		)

{- Transfer controls. The GET is done in noscript mode and redirects back
 - to the referring page. The POST is called by javascript. -}
getPauseTransferR :: Transfer -> Handler ()
getPauseTransferR = noscript postPauseTransferR
postPauseTransferR :: Transfer -> Handler ()
postPauseTransferR = liftAssistant . pauseTransfer
getStartTransferR :: Transfer -> Handler ()
getStartTransferR = noscript postStartTransferR
postStartTransferR :: Transfer -> Handler ()
postStartTransferR = liftAssistant . startTransfer
getCancelTransferR :: Transfer -> Handler ()
getCancelTransferR = noscript postCancelTransferR
postCancelTransferR :: Transfer -> Handler ()
postCancelTransferR = liftAssistant . cancelTransfer False

noscript :: (Transfer -> Handler ()) -> Transfer -> Handler ()
noscript a t = a t >> redirectBack


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

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

module Assistant.WebApp.Documentation where

import Assistant.WebApp.Common
import Assistant.Install (standaloneAppBase)
import Build.SysConfig (packageversion)
import BuildFlags

{- The full license info may be included in a file on disk that can
 - be read in and displayed. -}
licenseFile :: IO (Maybe FilePath)
licenseFile = do
	base <- standaloneAppBase
	return $ (</> "LICENSE") <$> base

getAboutR :: Handler Html
getAboutR = page "About git-annex" (Just About) $ do
	builtinlicense <- isJust <$> liftIO licenseFile
	$(widgetFile "documentation/about")

getLicenseR :: Handler Html
getLicenseR = do
	v <- liftIO licenseFile
	case v of
		Nothing -> redirect AboutR
		Just f -> customPage (Just About) $ do
			-- no sidebar, just pages of legalese..
			setTitle "License"
			license <- liftIO $ readFile f
			$(widgetFile "documentation/license")

getRepoGroupR :: Handler Html
getRepoGroupR = page "About repository groups" (Just About) $
	$(widgetFile "documentation/repogroup")


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

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

module Assistant.WebApp.Form where

import Assistant.WebApp.Types
import Assistant.Gpg

#if MIN_VERSION_yesod(1,2,0)
import Yesod hiding (textField, passwordField)
import Yesod.Form.Fields as F
#else
import Yesod hiding (textField, passwordField, selectField, selectFieldList)
import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
import Data.String (IsString (..))
import Control.Monad (unless)
import Data.Maybe (listToMaybe)
#endif
import Data.Text (Text)
import Assistant.WebApp.Bootstrap3 hiding (bfs)

{- Yesod's textField sets the required attribute for required fields.
 - We don't want this, because many of the forms used in this webapp
 - display a modal dialog when submitted, which interacts badly with
 - required field handling by the browser.
 -
 - Required fields are still checked by Yesod.
 -}
textField :: MkField Text
textField = F.textField
	{ fieldView = \theId name attrs val _isReq -> [whamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}">
|]
	}

readonlyTextField :: MkField Text
readonlyTextField = F.textField
	{ fieldView = \theId name attrs val _isReq -> [whamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}" readonly="true">
|]
	}

{- Also without required attribute. -}
passwordField :: MkField Text
passwordField = F.passwordField
	{ fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="password" value="#{either id id val}">
|]
	}

{- In older Yesod versions attrs is written into the <option> tag instead of the
 - surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
 - it requires the "form-control" class on the <select> tag.
 - We need to change that to behave the same way as in newer versions.
 -}
#if ! MIN_VERSION_yesod(1,2,0)
selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
selectFieldList = selectField . optionsPairs

selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
selectField = selectFieldHelper
	(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
	(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
	(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside

selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
	=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
	-> (Text -> Text -> Bool -> GWidget sub master ())
	-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
	-> GHandler sub master (OptionList a) -> Field sub master a
selectFieldHelper outside onOpt inside opts' = Field
	{ fieldParse = \x -> do
		opts <- opts'
		return $ selectParser opts x
	, fieldView = \theId name attrs val isReq -> do
		opts <- fmap olOptions $ lift opts'
		outside theId name attrs $ do
			unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
			flip mapM_ opts $ \opt -> inside
				theId
				name
				((if isReq then (("required", "required"):) else id) attrs)
				(optionExternalValue opt)
				((render opts val) == optionExternalValue opt)
				(optionDisplay opt)
	}
  where
	render _ (Left _) = ""
	render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
	selectParser _ [] = Right Nothing
	selectParser opts (s:_) = case s of
		"" -> Right Nothing
		"none" -> Right Nothing
		x -> case olReadExternal opts x of
			Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
			Just y -> Right $ Just y
#endif

{- Makes a note widget be displayed after a field. -}
#if MIN_VERSION_yesod(1,2,0)
withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
#else
withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
#endif
withNote field note = field { fieldView = newview }
  where
	newview theId name attrs val isReq =
		let fieldwidget = (fieldView field) theId name attrs val isReq
		in [whamlet|^{fieldwidget}  ^{note}|]

{- Note that the toggle string must be unique on the form. -}
#if MIN_VERSION_yesod(1,2,0)
withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
#else
withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
#endif
withExpandableNote field (toggle, note) = withNote field $ [whamlet|
#{toggle}

  ^{note}
|]
  where
  	ident = "toggle_" ++ toggle

{- Adds a check box to an AForm to control encryption. -}
#if MIN_VERSION_yesod(1,2,0)
enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
#else
enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
#endif
enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
  where
	choices :: [(Text, EnableEncryption)]
	choices =
		[ ("Encrypt all data", SharedEncryption)
		, ("Disable encryption", NoEncryption)
		]

{- Defines the layout used by the Bootstrap3 form helper -}
bootstrapFormLayout :: BootstrapFormLayout
bootstrapFormLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)

{- Adds the form-control class used by Bootstrap3 for layout to a field
 - This is the same as Yesod.Form.Bootstrap3.bfs except it takes just a Text
 - parameter as I couldn't get the original bfs to compile due to type ambiguities.
 -}
bfs :: Text -> FieldSettings master
bfs msg = FieldSettings
	{ fsLabel = SomeMessage msg
	, fsName  = Nothing
	, fsId    = Nothing
	, fsAttrs = [("class", "form-control")]
	, fsTooltip = Nothing
	}


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

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

module Assistant.WebApp.Gpg where

import Assistant.WebApp.Common
import Assistant.Gpg
import Utility.Gpg
import qualified Git.Command
import qualified Git.Remote
import qualified Git.Construct
import qualified Annex.Branch
import qualified Git.GCrypt
import qualified Remote.GCrypt as GCrypt
import Git.Types (RemoteName)
import Assistant.WebApp.MakeRemote
import Logs.Remote

import qualified Data.Map as M

gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
gpgKeyDisplay keyid userid = [whamlet|
  <span title="key id #{keyid}">
    <span .glyphicon .glyphicon-user>
    \
    $maybe name <- userid
      #{name}
    $nothing
      key id #{keyid}
|]

genKeyModal :: Widget
genKeyModal = $(widgetFile "configurators/genkeymodal")

isGcryptInstalled :: IO Bool
isGcryptInstalled = inPath "git-remote-gcrypt"

whenGcryptInstalled :: Handler Html -> Handler Html
whenGcryptInstalled a = ifM (liftIO isGcryptInstalled)
	( a
	, page "Need git-remote-gcrypt" (Just Configuration) $
		$(widgetFile "configurators/needgcrypt")
	)

withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html
withNewSecretKey use = do
	userid <- liftIO newUserId
	liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize
	results <- M.keys . M.filter (== userid) <$> liftIO secretKeys
	case results of
		[] -> error "Failed to generate gpg key!"
		(key:_) -> use key

{- Tries to find the name used in remote.log for a gcrypt repository
 - with a given uuid.
 -
 - The gcrypt remote may not be on that is listed in the local remote.log
 - (or the info may be out of date), so this actually fetches the git-annex
 - branch from the gcrypt remote and merges it in, and then looks up
 - the name.
 -}
getGCryptRemoteName :: UUID -> String -> Annex RemoteName
getGCryptRemoteName u repoloc = do
	tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
	void $ inRepo $ Git.Command.runBool
		[Params "remote add", Param tmpremote, Param $ Git.GCrypt.urlPrefix ++ repoloc]
	mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote])
		( do
			void Annex.Branch.forceUpdate
			(M.lookup "name" <=< M.lookup u) <$> readRemoteLog
		, return Nothing
		)
	void $ inRepo $ Git.Remote.remove tmpremote
	maybe missing return mname
  where
	missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc

{- Checks to see if a repo is encrypted with gcrypt, and runs one action if
 - it's not an another if it is.
 -
 - Since the probing requires gcrypt to be installed, a third action must
 - be provided to run if it's not installed.
 -}
checkGCryptRepoEncryption :: (Monad m, LiftAnnex m) => String -> m a -> m a -> m a -> m a
checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
	ifM (liftAnnex $ liftIO isGcryptInstalled)
		( dispatch =<< liftAnnex (inRepo $ Git.GCrypt.probeRepo location)
		, notinstalled
		)
  where
	dispatch Git.GCrypt.Decryptable = encrypted
	dispatch Git.GCrypt.NotEncrypted = notencrypted
	dispatch Git.GCrypt.NotDecryptable =
		error "This git repository is encrypted with a GnuPG key that you do not have."

{- Gets the UUID of the gcrypt repo at a location, which may not exist.
 - Only works if the gcrypt repo was created as a git-annex remote. -}
probeGCryptRemoteUUID :: String -> Annex (Maybe UUID)
probeGCryptRemoteUUID repolocation = do
	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation
	GCrypt.getGCryptUUID False r


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

module Assistant.WebApp.MakeRemote (
	module Assistant.MakeRemote,
	module Assistant.WebApp.MakeRemote
) where

import Assistant.Common
import Assistant.WebApp.Types
import Assistant.Sync
import qualified Remote
import qualified Types.Remote as Remote
import qualified Config
import Config.Cost
import Types.StandardGroups
import Git.Types (RemoteName)
import Logs.PreferredContent
import Assistant.MakeRemote

import Utility.Yesod

{- Runs an action that creates or enables a cloud remote,
 - and finishes setting it up, then starts syncing with it,
 - and finishes by displaying the page to edit it.
 -
 - This includes displaying the connectionNeeded nudge if appropariate.
 -}
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupCloudRemote = setupRemote postsetup . Just
  where
	postsetup = redirect . EditNewCloudRepositoryR . Remote.uuid

setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupRemote postsetup mgroup mcost getname = do
	r <- liftAnnex $ addRemote getname
	liftAnnex $ do
		maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
		maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
	liftAssistant $ syncRemote r
	postsetup r


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

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

#if defined VERSION_yesod_default
#if ! MIN_VERSION_yesod_default(1,1,0)
#define WITH_OLD_YESOD
#endif
#endif

module Assistant.WebApp.Notifications where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.DaemonStatus
import Assistant.Types.Buddies
import Utility.NotificationBroadcaster
import Utility.Yesod
import Utility.WebApp

import Data.Text (Text)
import qualified Data.Text as T
#ifndef WITH_OLD_YESOD
import qualified Data.Aeson.Types as Aeson
#endif

{- Add to any widget to make it auto-update using long polling.
 -
 - The widget should have a html element with an id=ident, which will be
 - replaced when it's updated.
 -
 - The geturl route should return the notifier url to use for polling.
 -
 - ms_delay is how long to delay between AJAX updates
 - ms_startdelay is how long to delay before updating with AJAX at the start
 -}
autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
autoUpdate tident geturl ms_delay ms_startdelay = do
#ifdef WITH_OLD_YESOD
	let delay = show ms_delay
	let startdelay = show ms_startdelay
	let ident = "'" ++ T.unpack tident ++ "'"
#else
	let delay = Aeson.String (T.pack (show ms_delay))
	let startdelay = Aeson.String (T.pack (show ms_startdelay))
	let ident = Aeson.String tident
#endif
	$(widgetFile "notifications/longpolling")

{- Notifier urls are requested by the javascript, to avoid allocation
 - of NotificationIds when noscript pages are loaded. This constructs a
 - notifier url for a given Route and NotificationBroadcaster.
 -}
notifierUrl :: (NotificationId -> Route WebApp) -> Assistant NotificationBroadcaster -> Handler RepPlain
notifierUrl route broadcaster = do
	(urlbits, _params) <- renderRoute . route <$> newNotifier broadcaster
	webapp <- getYesod
	return $ RepPlain $ toContent $ T.concat
		[ "/"
		, T.intercalate "/" urlbits
		, "?auth="
		, fromAuthToken (authToken webapp)
		]

getNotifierTransfersR :: Handler RepPlain
getNotifierTransfersR = notifierUrl TransfersR getTransferBroadcaster

getNotifierSideBarR :: Handler RepPlain
getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster

getNotifierBuddyListR :: Handler RepPlain
getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster

getNotifierRepoListR :: RepoSelector -> Handler RepPlain
getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
  where
	route nid = RepoListR nid reposelector

getNotifierGlobalRedirR :: Handler RepPlain
getNotifierGlobalRedirR = notifierUrl GlobalRedirR getGlobalRedirBroadcaster

getTransferBroadcaster :: Assistant NotificationBroadcaster
getTransferBroadcaster = transferNotifier <$> getDaemonStatus

getAlertBroadcaster :: Assistant NotificationBroadcaster
getAlertBroadcaster = alertNotifier <$> getDaemonStatus

getBuddyListBroadcaster :: Assistant NotificationBroadcaster
getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList

getRepoListBroadcaster :: Assistant NotificationBroadcaster
getRepoListBroadcaster =  syncRemotesNotifier <$> getDaemonStatus

getGlobalRedirBroadcaster :: Assistant NotificationBroadcaster
getGlobalRedirBroadcaster =  globalRedirNotifier <$> getDaemonStatus

getGlobalRedirR :: NotificationId -> Handler RepPlain
getGlobalRedirR nid = do
	waitNotifier getGlobalRedirBroadcaster nid
	maybe (getGlobalRedirR nid) (return . RepPlain . toContent . T.pack)
		=<< globalRedirUrl <$> liftAssistant getDaemonStatus


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

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

module Assistant.WebApp.OtherRepos where

import Assistant.Common
import Assistant.WebApp.Types
import Assistant.WebApp.Page
import Config.Files
import Utility.Yesod
import Assistant.Restart

getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
	repolist <- liftIO listOtherRepos
	$(widgetFile "control/repositoryswitcher")

listOtherRepos :: IO [(String, String)]
listOtherRepos = do
	dirs <- readAutoStartFile
	pwd <- getCurrentDirectory
	gooddirs <- filterM isrepo $
		filter (\d -> not $ d `dirContains` pwd) dirs
	names <- mapM relHome gooddirs
	return $ sort $ zip names gooddirs
  where
	isrepo d = doesDirectoryExist (d </> ".git")

getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do
	liftIO $ addAutoStartFile repo -- make this the new default repo
	redirect =<< liftIO (newAssistantUrl repo)


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

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

module Assistant.WebApp.Page where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod

import qualified Text.Hamlet as Hamlet
import Data.Text (Text)

data NavBarItem = DashBoard | Configuration | About
	deriving (Eq, Ord, Enum, Bounded)

navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Configuration = "Configuration"
navBarName About = "About"

navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = DashboardR
navBarRoute Configuration = ConfigurationR
navBarRoute About = AboutR

defaultNavBar :: [NavBarItem]
defaultNavBar = [minBound .. maxBound]

firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Configuration, About]

selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM inFirstRun (return firstRunNavBar, return defaultNavBar)

{- A standard page of the webapp, with a title, a sidebar, and that may
 - be highlighted on the navbar. -}
page :: Hamlet.Html -> Maybe NavBarItem -> Widget -> Handler Html
page title navbaritem content = customPage navbaritem $ do
	setTitle title
	content
	sideBarDisplay

{- A custom page, with no title or sidebar set. -}
customPage :: Maybe NavBarItem -> Widget -> Handler Html
customPage = customPage' True

customPage' :: Bool -> Maybe NavBarItem -> Widget -> Handler Html
customPage' with_longpolling navbaritem content = do
	webapp <- getYesod
	case cannotRun webapp of
		Nothing -> do
			navbar <- map navdetails <$> selectNavBar
			pageinfo <- widgetToPageContent $ do
				addStylesheet $ StaticR css_bootstrap_css
				addStylesheet $ StaticR css_bootstrap_theme_css
				addScript $ StaticR js_jquery_full_js
				addScript $ StaticR js_bootstrap_js
				when with_longpolling $
					addScript $ StaticR js_longpolling_js
				$(widgetFile "page")
			giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
		Just msg -> error msg
  where
	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)

hasFileBrowser :: Bool
#ifdef ANDROID_SPLICES
hasFileBrowser = False
#else
hasFileBrowser = True
#endif

controlMenu :: Widget
controlMenu = $(widgetFile "controlmenu")


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

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

module Assistant.WebApp.Repair where

import Assistant.WebApp.Common
import Assistant.WebApp.RepoList
import Remote (prettyUUID, remoteFromUUID)
import Annex.UUID (getUUID)
import Assistant.Repair

getRepairRepositoryR :: UUID -> Handler Html
getRepairRepositoryR = postRepairRepositoryR
postRepairRepositoryR :: UUID -> Handler Html
postRepairRepositoryR u = page "Repair repository" Nothing $ do
	repodesc <- liftAnnex $ prettyUUID u
	repairingmainrepo <- (==) u <$> liftAnnex getUUID
	$(widgetFile "control/repairrepository")

getRepairRepositoryRunR :: UUID -> Handler Html
getRepairRepositoryRunR = postRepairRepositoryRunR
postRepairRepositoryRunR :: UUID -> Handler Html
postRepairRepositoryRunR u = do
	r <- liftAnnex $ remoteFromUUID u
	void $ liftAssistant $ runRepair u r True
	page "Repair repository" Nothing $ do
		let repolist = repoListDisplay $
			mainRepoSelector { nudgeAddMore = True }
		$(widgetFile "control/repairrepository/done")


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

module Assistant.WebApp.RepoId where

import Common.Annex
import Git.Types (RemoteName)
import qualified Remote

{- Parts of the webapp need to be able to act on repositories that may or
 - may not have a UUID. -}
data RepoId
	= RepoUUID UUID
	| RepoName RemoteName
  deriving (Eq, Ord, Show, Read)

mkRepoId :: Remote -> RepoId
mkRepoId r = case Remote.uuid r of
	NoUUID -> RepoName (Remote.name r)
	u -> RepoUUID u

describeRepoId :: RepoId -> Annex String
describeRepoId (RepoUUID u) = Remote.prettyUUID u
describeRepoId (RepoName n) = return n

repoIdRemote :: RepoId -> Annex (Maybe Remote)
repoIdRemote (RepoUUID u) = Remote.remoteFromUUID u
repoIdRemote (RepoName n) = Remote.byNameOnly n

lacksUUID :: RepoId -> Bool
lacksUUID r = asUUID r == NoUUID

asUUID :: RepoId -> UUID
asUUID (RepoUUID u) = u
asUUID _ = NoUUID


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

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

module Assistant.WebApp.RepoList where

import Assistant.WebApp.Common
import Assistant.DaemonStatus
import Assistant.WebApp.Notifications
import qualified Annex
import qualified Remote
import qualified Types.Remote as Remote
import Remote.List (remoteListRefresh)
import Annex.UUID (getUUID)
import Logs.Remote
import Logs.Trust
import Logs.Group
import Config
import Git.Remote
import Assistant.Sync
import Config.Cost
import Utility.NotificationBroadcaster
import qualified Git

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Function
import Control.Concurrent

type RepoList = [(RepoDesc, RepoId, CurrentlyConnected, Actions)]

type RepoDesc = String
type CurrentlyConnected = Bool

{- Actions that can be performed on a repo in the list. -}
data Actions
	= DisabledRepoActions
		{ setupRepoLink :: Route WebApp }
	| SyncingRepoActions
		{ setupRepoLink :: Route WebApp
		, syncToggleLink :: Route WebApp
		}
	| NotSyncingRepoActions
		{ setupRepoLink :: Route WebApp
		, syncToggleLink :: Route WebApp
		}
	| UnwantedRepoActions
		{ setupRepoLink :: Route WebApp }

mkSyncingRepoActions :: RepoId -> Actions
mkSyncingRepoActions repoid = SyncingRepoActions
	{ setupRepoLink = EditRepositoryR repoid
	, syncToggleLink = DisableSyncR repoid
	}

mkNotSyncingRepoActions :: RepoId -> Actions
mkNotSyncingRepoActions repoid = NotSyncingRepoActions
	{ setupRepoLink = EditRepositoryR repoid
	, syncToggleLink = EnableSyncR repoid
	}

mkUnwantedRepoActions :: RepoId -> Actions
mkUnwantedRepoActions repoid = UnwantedRepoActions
	{ setupRepoLink = EditRepositoryR repoid
	}

needsEnabled :: Actions -> Bool
needsEnabled (DisabledRepoActions _) = True
needsEnabled _ = False

notSyncing :: Actions -> Bool
notSyncing (SyncingRepoActions _ _) = False
notSyncing _ = True

notWanted :: Actions -> Bool
notWanted (UnwantedRepoActions _) = True
notWanted _ = False

{- Called by client to get a list of repos, that refreshes
 - when new repos are added.
 -
 - Returns a div, which will be inserted into the calling page.
 -}
getRepoListR :: NotificationId -> RepoSelector -> Handler Html
getRepoListR nid reposelector = do
	waitNotifier getRepoListBroadcaster nid
	p <- widgetToPageContent $ repoListDisplay reposelector
	giveUrlRenderer $ [hamlet|^{pageBody p}|]

mainRepoSelector :: RepoSelector
mainRepoSelector = RepoSelector
	{ onlyCloud = False
	, onlyConfigured = False
	, includeHere = True
	, nudgeAddMore = False
	}

{- List of cloud repositories, configured and not. -}
cloudRepoList :: Widget
cloudRepoList = repoListDisplay RepoSelector
	{ onlyCloud = True
	, onlyConfigured = False
	, includeHere = False
	, nudgeAddMore = False
	}

repoListDisplay :: RepoSelector -> Widget
repoListDisplay reposelector = do
	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
	addScript $ StaticR js_jquery_ui_core_js
	addScript $ StaticR js_jquery_ui_widget_js
	addScript $ StaticR js_jquery_ui_mouse_js
	addScript $ StaticR js_jquery_ui_sortable_js

	repolist <- liftH $ repoList reposelector
	let addmore = nudgeAddMore reposelector
	let nootherrepos = length repolist < 2

	$(widgetFile "repolist")
  where
	ident = "repolist"

{- A list of known repositories, with actions that can be taken on them. -}
repoList :: RepoSelector -> Handler RepoList
repoList reposelector
	| onlyConfigured reposelector = list =<< configured
	| otherwise = list =<< (++) <$> configured <*> unconfigured
  where
	configured = do
		syncremotes <- syncRemotes <$> liftAssistant getDaemonStatus
		let syncing = S.fromList $ map mkRepoId syncremotes
		liftAnnex $ do
			unwanted <- S.fromList
				<$> filterM inUnwantedGroup (map Remote.uuid syncremotes)
			rs <- filter selectedrepo . concat . Remote.byCost
				<$> Remote.remoteList
			let l = flip map (map mkRepoId rs) $ \r -> case r of
				(RepoUUID u)
					| u `S.member` unwanted -> (r, mkUnwantedRepoActions r)
				_
					| r `S.member` syncing -> (r, mkSyncingRepoActions r)
					| otherwise -> (r, mkNotSyncingRepoActions r)
			if includeHere reposelector
				then do
					r <- RepoUUID <$> getUUID
					autocommit <- annexAutoCommit <$> Annex.getGitConfig
					let hereactions = if autocommit
						then mkSyncingRepoActions r
						else mkNotSyncingRepoActions r
					let here = (r, hereactions)
					return $ here : l
				else return l
	unconfigured = liftAnnex $ do
		m <- readRemoteLog
		g <- gitRepo
		map snd . catMaybes . filter selectedremote
			. map (findinfo m g)
			<$> trustExclude DeadTrusted (M.keys m)
	selectedrepo r
		| Remote.readonly r = False
		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r)
			&& Remote.uuid r /= NoUUID
			&& not (Remote.isXMPPRemote r)
		| otherwise = True
	selectedremote Nothing = False
	selectedremote (Just (iscloud, _))
		| onlyCloud reposelector = iscloud
		| otherwise = True
	findinfo m g u = case getconfig "type" of
		Just "rsync" -> val True EnableRsyncR
		Just "directory" -> val False EnableDirectoryR
#ifdef WITH_S3
		Just "S3" -> val True EnableS3R
#endif
		Just "glacier" -> val True EnableGlacierR
#ifdef WITH_WEBDAV
		Just "webdav" -> val True EnableWebDAVR
#endif
		Just "gcrypt" ->
			-- Skip gcrypt repos on removable drives;
			-- handled separately.
			case getconfig "gitrepo" of
				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr g) ->
					val True EnableSshGCryptR
				_ -> Nothing
		Just "git" ->
			case getconfig "location" of
				Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc g) ->
					val True EnableSshGitRemoteR
				_ -> Nothing
		_ -> Nothing
	  where
	  	getconfig k = M.lookup k =<< M.lookup u m
		val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
	list l = do
		cc <- currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
		forM (nubBy ((==) `on` fst) l) $ \(repoid, actions) ->
			(,,,)
				<$> liftAnnex (describeRepoId repoid)
				<*> pure repoid
				<*> pure (getCurrentlyConnected repoid cc)
				<*> pure actions

getCurrentlyConnected :: RepoId -> S.Set UUID -> CurrentlyConnected
getCurrentlyConnected (RepoUUID u) cc = S.member u cc
getCurrentlyConnected _ _ = False

getEnableSyncR :: RepoId -> Handler ()
getEnableSyncR = flipSync True

getDisableSyncR :: RepoId -> Handler ()
getDisableSyncR = flipSync False

flipSync :: Bool -> RepoId -> Handler ()
flipSync enable repoid = do
	mremote <- liftAnnex $ repoIdRemote repoid
	liftAssistant $ changeSyncable mremote enable
	redirectBack

getRepositoriesReorderR :: Handler ()
getRepositoriesReorderR = do
	{- Get uuid of the moved item, and the list it was moved within. -}
	moved <- fromjs <$> runInputGet (ireq textField "moved")
	list <- map fromjs <$> lookupGetParams "list[]"
	liftAnnex $ go list =<< repoIdRemote moved
	liftAssistant updateSyncRemotes
  where
	go _ Nothing = noop
  	go list (Just remote) = do
		rs <- catMaybes <$> mapM repoIdRemote list
		forM_ (reorderCosts remote rs) $ \(r, newcost) ->
			when (Remote.cost r /= newcost) $
				setRemoteCost (Remote.repo r) newcost
		void remoteListRefresh
  	fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack

reorderCosts :: Remote -> [Remote] -> [(Remote, Cost)]
reorderCosts remote rs = zip rs'' (insertCostAfter costs i)
  where
	{- Find the index of the remote in the list that the remote
	 - was moved to be after.
	 - If it was moved to the start of the list, -1 -}
	i = fromMaybe 0 (elemIndex remote rs) - 1
	rs' = filter (\r -> Remote.uuid r /= Remote.uuid remote) rs
	costs = map Remote.cost rs'
	rs'' = (\(x, y) -> x ++ [remote] ++ y) $ splitAt (i + 1) rs'

getSyncNowRepositoryR :: UUID -> Handler ()
getSyncNowRepositoryR uuid = do
	u <- liftAnnex getUUID
	if u == uuid
		then do
			thread <- liftAssistant $ asIO $
				reconnectRemotes True
					=<< (syncRemotes <$> getDaemonStatus)
			void $ liftIO $ forkIO thread
		else maybe noop (liftAssistant . syncRemote)
			=<< liftAnnex (Remote.remoteFromUUID uuid)
	redirectBack


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

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

module Assistant.WebApp.SideBar where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.Notifications
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Utility.Yesod

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
import Control.Concurrent

sideBarDisplay :: Widget
sideBarDisplay = do
	let content = do
		{- Add newest alerts to the sidebar. -}
		alertpairs <- liftH $ M.toList . alertMap
			<$> liftAssistant getDaemonStatus
		mapM_ renderalert $
			take displayAlerts $ reverse $ sortAlertPairs alertpairs
	let ident = "sidebar"
	$(widgetFile "sidebar/main")
	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
  where
	bootstrapclass :: AlertClass -> Text
	bootstrapclass Activity = "alert-info"
	bootstrapclass Warning = "alert"
	bootstrapclass Error = "alert-danger"
	bootstrapclass Success = "alert-success"
	bootstrapclass Message = "alert-info"

	renderalert (aid, alert) = do
		let alertid = show aid
		let closable = alertClosable alert
		let block = alertBlockDisplay alert
		let divclass = bootstrapclass $ alertClass alert
		let message = renderAlertMessage alert
		let messagelines = T.lines message
		let multiline = length messagelines > 1
		let buttons = zip (alertButtons alert) [1..]
		$(widgetFile "sidebar/alert")

{- Called by client to get a sidebar display.
 -
 - Returns a div, which will be inserted into the calling page.
 -
 - Note that the head of the widget is not included, only its
 - body is. To get the widget head content, the widget is also
 - inserted onto all pages.
 -}
getSideBarR :: NotificationId -> Handler Html
getSideBarR nid = do
	waitNotifier getAlertBroadcaster nid

	{- This 0.1 second delay avoids very transient notifications from
	 - being displayed and churning the sidebar unnecesarily.
	 -
	 - This needs to be below the level perceptable by the user,
	 - to avoid slowing down user actions like closing alerts. -}
	liftIO $ threadDelay 100000

	page <- widgetToPageContent sideBarDisplay
	giveUrlRenderer $ [hamlet|^{pageBody page}|]

{- Called by the client to close an alert. -}
getCloseAlert :: AlertId -> Handler ()
getCloseAlert = liftAssistant . removeAlert

{- When an alert with a button is clicked on, the button takes us here. -}
getClickAlert :: AlertId -> Int -> Handler ()
getClickAlert i bnum = do
	m <- alertMap <$> liftAssistant getDaemonStatus
	case M.lookup i m of
		Just (Alert { alertButtons = bs })
			| length bs >= bnum -> do
				let b = bs !! (bnum - 1)
				{- Spawn a thread to run the action
				 - while redirecting. -}
				case buttonAction b of
					Nothing -> noop
					Just a -> liftIO $ void $ forkIO $ a i
				redirect $ buttonUrl b
			| otherwise -> redirectBack
		_ -> redirectBack

htmlIcon :: AlertIcon -> Widget
htmlIcon ActivityIcon = [whamlet||]
htmlIcon SyncIcon = [whamlet||]
htmlIcon InfoIcon = bootstrapIcon "info-sign"
htmlIcon SuccessIcon = bootstrapIcon "ok"
htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
htmlIcon ConnectionIcon = bootstrapIcon "signal"

bootstrapIcon :: Text -> Widget
bootstrapIcon name = [whamlet||]


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

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Assistant.WebApp.Types where

import Assistant.Common
import Assistant.Ssh
import Assistant.Pairing
import Assistant.Types.Buddies
import Utility.NotificationBroadcaster
import Utility.WebApp
import Utility.Yesod
import Logs.Transfer
import Utility.Gpg (KeyId)
import Build.SysConfig (packageversion)
import Types.ScheduledActivity
import Assistant.WebApp.RepoId
import Types.Distribution

import Yesod.Static
import Text.Hamlet
import Data.Text (Text, pack, unpack)
import Network.Socket (HostName)

publicFiles "static"

staticRoutes :: Static
staticRoutes = $(embed "static")

mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")

data WebApp = WebApp
	{ assistantData :: AssistantData
	, authToken :: AuthToken
	, relDir :: Maybe FilePath
	, getStatic :: Static
	, postFirstRun :: Maybe (IO String)
	, cannotRun :: Maybe String
	, noAnnex :: Bool
	, listenHost ::Maybe HostName
	}

instance Yesod WebApp where
	{- Require an auth token be set when accessing any (non-static) route -}
	isAuthorized _ _ = checkAuthToken authToken

	{- Add the auth token to every url generated, except static subsite
	 - urls (which can show up in Permission Denied pages). -}
	joinPath = insertAuthToken authToken excludeStatic
	  where
		excludeStatic [] = True
		excludeStatic (p:_) = p /= "static"

	makeSessionBackend = webAppSessionBackend
	jsLoader _ = BottomOfHeadBlocking

	{- The webapp does not use defaultLayout, so this is only used
	 - for error pages or any other built-in yesod page.
	 -
	 - This can use static routes, but should use no other routes,
	 - as that would expose the auth token.
	 -}
	defaultLayout content = do
		webapp <- getYesod
		pageinfo <- widgetToPageContent $ do
			addStylesheet $ StaticR css_bootstrap_css
			addStylesheet $ StaticR css_bootstrap_theme_css
			addScript $ StaticR js_jquery_full_js
			addScript $ StaticR js_bootstrap_js
			$(widgetFile "error")
		giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")

instance RenderMessage WebApp FormMessage where
	renderMessage _ _ = defaultFormMessage

#if MIN_VERSION_yesod(1,2,0)
instance LiftAnnex Handler where
#else
instance LiftAnnex (GHandler sub WebApp) where
#endif
	liftAnnex a = ifM (noAnnex <$> getYesod)
		( error "internal liftAnnex"
		, liftAssistant $ liftAnnex a
		)

#if MIN_VERSION_yesod(1,2,0)
instance LiftAnnex (WidgetT WebApp IO) where
#else
instance LiftAnnex (GWidget WebApp WebApp) where
#endif
	liftAnnex = liftH . liftAnnex

class LiftAssistant m where
	liftAssistant :: Assistant a -> m a

#if MIN_VERSION_yesod(1,2,0)
instance LiftAssistant Handler where
#else
instance LiftAssistant (GHandler sub WebApp) where
#endif
	liftAssistant a = liftIO . flip runAssistant a
		=<< assistantData <$> getYesod

#if MIN_VERSION_yesod(1,2,0)
instance LiftAssistant (WidgetT WebApp IO) where
#else
instance LiftAssistant (GWidget WebApp WebApp) where
#endif
	liftAssistant = liftH . liftAssistant

#if MIN_VERSION_yesod(1,2,0)
type MkMForm x = MForm Handler (FormResult x, Widget)
#else
type MkMForm x = MForm WebApp WebApp (FormResult x, Widget)
#endif

#if MIN_VERSION_yesod(1,2,0)
type MkAForm x = AForm Handler x
#else
type MkAForm x = AForm WebApp WebApp x
#endif

#if MIN_VERSION_yesod(1,2,0)
type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
#else
type MkField x = RenderMessage master FormMessage => Field sub master x
#endif

data RepoSelector = RepoSelector
	{ onlyCloud :: Bool
	, onlyConfigured :: Bool
	, includeHere :: Bool
	, nudgeAddMore :: Bool
	}
	deriving (Read, Show, Eq)

data RemovableDrive = RemovableDrive
	{ diskFree :: Maybe Integer
	, mountPoint :: Text
	, driveRepoPath :: Text
	}
	deriving (Read, Show, Eq, Ord)

data RepoKey = RepoKey KeyId | NoRepoKey
	deriving (Read, Show, Eq, Ord)

#if ! MIN_VERSION_path_pieces(0,1,4)
instance PathPiece Bool where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack
#endif

instance PathPiece RemovableDrive where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece RepoKey where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece SshData where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece NotificationId where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece AlertId where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece Transfer where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece PairMsg where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece SecretReminder where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece UUID where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece BuddyKey where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece PairKey where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece RepoSelector where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece ThreadName where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece ScheduledActivity where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece RepoId where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack

instance PathPiece GitAnnexDistribution where
	toPathPiece = pack . show
	fromPathPiece = readish . unpack


code:
/ DashboardR GET HEAD

/noscript NoScriptR GET
/noscript/auto NoScriptAutoR GET

/about AboutR GET
/about/license LicenseR GET
/about/repogroups RepoGroupR GET

/shutdown ShutdownR GET
/shutdown/confirm ShutdownConfirmedR GET
/shutdown/complete NotRunningR GET
/restart RestartR GET
/restart/thread/#ThreadName RestartThreadR GET
/log LogR GET

/config ConfigurationR GET
/config/preferences PreferencesR GET POST
/config/xmpp XMPPConfigR GET POST
/config/xmpp/for/self XMPPConfigForPairSelfR GET POST
/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
/config/xmpp/disconnect DisconnectXMPPR GET
/config/needconnection ConnectionNeededR GET
/config/fsck ConfigFsckR GET POST
/config/fsck/preferences ConfigFsckPreferencesR POST
/config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
/config/upgrade/finish ConfigFinishUpgradeR GET
/config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET
/config/unused ConfigUnusedR GET POST

/config/addrepository AddRepositoryR GET
/config/repository/new NewRepositoryR GET POST
/config/repository/new/first FirstRepositoryR GET POST
/config/repository/new/androidcamera AndroidCameraRepositoryR GET
/config/repository/switcher RepositorySwitcherR GET
/config/repository/switchto/#FilePath SwitchToRepositoryR GET
/config/repository/combine/#FilePath/#UUID CombineRepositoryR GET
/config/repository/edit/#RepoId EditRepositoryR GET POST
/config/repository/edit/new/#UUID EditNewRepositoryR GET POST
/config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
/config/repository/sync/disable/#RepoId DisableSyncR GET
/config/repository/sync/enable/#RepoId EnableSyncR GET
/config/repository/upgrade/#RepoId UpgradeRepositoryR GET

/config/repository/add/drive AddDriveR GET POST
/config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET
/config/repository/add/drive/genkey/#RemovableDrive GenKeyForDriveR GET
/config/repository/add/drive/finish/#RemovableDrive/#RepoKey FinishAddDriveR GET
/config/repository/add/ssh AddSshR GET POST
/config/repository/add/ssh/confirm/#SshData/#UUID ConfirmSshR GET
/config/repository/add/ssh/retry/#SshData RetrySshR GET
/config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
/config/repository/add/ssh/make/gcrypt/#SshData/#RepoKey MakeSshGCryptR GET
/config/repository/add/ssh/combine/#SshData CombineSshR GET
/config/repository/add/cloud/rsync.net AddRsyncNetR GET POST
/config/repository/add/cloud/rsync.net/shared/#SshData MakeRsyncNetSharedR GET
/config/repository/add/cloud/rsync.net/gcrypt/#SshData/#RepoKey MakeRsyncNetGCryptR GET
/config/repository/add/cloud/S3 AddS3R GET POST
/config/repository/add/cloud/IA AddIAR GET POST
/config/repository/add/cloud/glacier AddGlacierR GET POST
/config/repository/add/cloud/box.com AddBoxComR GET POST

/config/repository/pair/local/start StartLocalPairR GET POST
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST

/config/repository/pair/xmpp/self/start StartXMPPPairSelfR GET
/config/repository/pair/xmpp/self/running RunningXMPPPairSelfR GET

/config/repository/pair/xmpp/friend/start StartXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/running/#BuddyKey RunningXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/accept/#PairKey ConfirmXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET

/config/repository/enable/rsync/#UUID EnableRsyncR GET POST
/config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST
/config/repository/enable/directory/#UUID EnableDirectoryR GET
/config/repository/enable/S3/#UUID EnableS3R GET POST
/config/repository/enable/IA/#UUID EnableIAR GET POST
/config/repository/enable/glacier/#UUID EnableGlacierR GET POST
/config/repository/enable/webdav/#UUID EnableWebDAVR GET POST
/config/repository/enable/sshgitremote/#UUID EnableSshGitRemoteR GET POST

/config/repository/reorder RepositoriesReorderR GET

/config/repository/syncnow/#UUID SyncNowRepositoryR GET
/config/repository/disable/#UUID DisableRepositoryR GET

/config/repository/delete/confirm/#UUID DeleteRepositoryR GET
/config/repository/delete/start/#UUID StartDeleteRepositoryR GET
/config/repository/delete/finish/#UUID FinishDeleteRepositoryR GET
/config/repository/delete/here DeleteCurrentRepositoryR GET POST

/config/activity/add/#UUID AddActivityR GET POST
/config/activity/change/#UUID/#ScheduledActivity ChangeActivityR GET POST
/config/activity/remove/#UUID/#ScheduledActivity RemoveActivityR GET

/transfers/#NotificationId TransfersR GET
/notifier/transfers NotifierTransfersR GET

/sidebar/#NotificationId SideBarR GET
/notifier/sidebar NotifierSideBarR GET

/buddylist/#NotificationId BuddyListR GET
/notifier/buddylist NotifierBuddyListR GET

/repolist/#NotificationId/#RepoSelector RepoListR GET
/notifier/repolist/#RepoSelector NotifierRepoListR GET

/globalredir/#NotificationId GlobalRedirR GET
/notifier/globalredir NotifierGlobalRedirR GET

/alert/close/#AlertId CloseAlert GET
/alert/click/#AlertId/#Int ClickAlert GET
/filebrowser FileBrowserR GET POST

/transfer/pause/#Transfer PauseTransferR GET POST
/transfer/start/#Transfer StartTransferR GET POST
/transfer/cancel/#Transfer CancelTransferR GET POST

/repair/#UUID RepairRepositoryR GET POST
/repair/run/#UUID RepairRepositoryRunR GET POST

/unused/cleanup CleanupUnusedR GET

/static StaticR Static getStatic

path: Assistant/WebApp/routes


code:
{- core xmpp support
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

module Assistant.XMPP where

import Assistant.Common
import Assistant.Types.NetMessager
import Assistant.Pairing
import Git.Sha (extractSha)
import Git

import Network.Protocol.XMPP hiding (Node)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.XML.Types
import qualified "dataenc" Codec.Binary.Base64 as B64

{- Name of the git-annex tag, in our own XML namespace.
 - (Not using a namespace URL to avoid unnecessary bloat.) -}
gitAnnexTagName :: Name
gitAnnexTagName  = "{git-annex}git-annex"

{- Creates a git-annex tag containing a particular attribute and value. -}
gitAnnexTag :: Name -> Text -> Element
gitAnnexTag attr val = gitAnnexTagContent attr val []

{- Also with some content. -}
gitAnnexTagContent :: Name -> Text -> [Node] -> Element
gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]

isGitAnnexTag :: Element -> Bool
isGitAnnexTag t = elementName t == gitAnnexTagName

{- Things that a git-annex tag can inserted into. -}
class GitAnnexTaggable a where
	insertGitAnnexTag :: a -> Element -> a

	extractGitAnnexTag :: a -> Maybe Element

	hasGitAnnexTag :: a -> Bool
	hasGitAnnexTag = isJust . extractGitAnnexTag

instance GitAnnexTaggable Message where
	insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m }
	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads

instance GitAnnexTaggable Presence where
	-- always mark extended away and set presence priority to negative
	insertGitAnnexTag p elt = p
		{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }
	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads

data GitAnnexTagInfo = GitAnnexTagInfo
	{ tagAttr :: Name
	, tagValue :: Text
	, tagElement :: Element
	}

type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage

gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
gitAnnexTagInfo v = case extractGitAnnexTag v of
	{- Each git-annex tag has a single attribute. -}
	Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo
		<$> pure attr
		<*> attributeText attr tag
		<*> pure tag
	_ -> Nothing

{- A presence with a git-annex tag in it.
 - Also includes a status tag, which may be visible in XMPP clients. -}
gitAnnexPresence :: Element -> Presence
gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable
  where
	addStatusTag p = p
		{ presencePayloads = status : presencePayloads p }
	status = Element "status" [] [statusMessage]
	statusMessage = NodeContent $ ContentText $ T.pack "git-annex"

{- A presence with an empty git-annex tag in it, used for letting other
 - clients know we're around and are a git-annex client. -}
gitAnnexSignature :: Presence
gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []

{- XMPP client to server ping -}
xmppPing :: JID -> IQ
xmppPing selfjid = (emptyIQ IQGet)
	{ iqID = Just "c2s1"
	, iqFrom = Just selfjid
	, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing
	, iqPayload = Just $ Element xmppPingTagName [] []
	}

xmppPingTagName :: Name
xmppPingTagName = "{urn:xmpp}ping"

{- A message with a git-annex tag in it. -}
gitAnnexMessage :: Element -> JID -> JID -> Message
gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
	{ messageTo = Just tojid
	, messageFrom = Just fromjid
	}

{- A notification that we've pushed to some repositories, listing their
 - UUIDs. -}
pushNotification :: [UUID] -> Presence
pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification

encodePushNotification :: [UUID] -> Text
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)

decodePushNotification :: Text -> [UUID]
decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep

uuidSep :: Text
uuidSep = ","

{- A request for other git-annex clients to send presence. -}
presenceQuery :: Presence
presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty

{- A notification about a stage of pairing. -}
pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
pairingNotification pairstage u = gitAnnexMessage $
	gitAnnexTag pairAttr $ encodePairingNotification pairstage u

encodePairingNotification :: PairStage -> UUID -> Text
encodePairingNotification pairstage u = T.unwords $ map T.pack
	[ show pairstage
	, fromUUID u
	]

decodePairingNotification :: Decoder
decodePairingNotification m = parse . words . T.unpack . tagValue
  where
	parse [stage, u] = PairingNotification
		<$> readish stage
		<*> (formatJID <$> messageFrom m)
		<*> pure (toUUID u)
	parse _ = Nothing

pushMessage :: PushStage -> JID -> JID -> Message
pushMessage = gitAnnexMessage . encode
  where
	encode (CanPush u shas) =
		gitAnnexTag canPushAttr $ T.pack $ unwords $
			fromUUID u : map fromRef shas
	encode (PushRequest u) =
		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
	encode (StartingPush u) =
		gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
	encode (ReceivePackOutput n b) =
		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
	encode (SendPackOutput n b) =
		gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b
	encode (ReceivePackDone code) =
		gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code
	val = T.pack . show

decodeMessage :: Message -> Maybe NetMessage
decodeMessage m = decode =<< gitAnnexTagInfo m
  where
	decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
	rundecoder i d = d m i
	decoders = M.fromList $ zip
		[ pairAttr
		, canPushAttr
		, pushRequestAttr
		, startingPushAttr
		, receivePackAttr
		, sendPackAttr
		, receivePackDoneAttr
		]
		[ decodePairingNotification
		, pushdecoder $ shasgen CanPush
		, pushdecoder $ gen PushRequest
		, pushdecoder $ gen StartingPush
		, pushdecoder $ seqgen ReceivePackOutput
		, pushdecoder $ seqgen SendPackOutput
		, pushdecoder $
			fmap (ReceivePackDone . decodeExitCode) . readish .
				T.unpack . tagValue
		]
	pushdecoder a m' i = Pushing
		<$> (formatJID <$> messageFrom m')
		<*> a i
	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
	seqgen c i = do
	  	packet <- decodeTagContent $ tagElement i
		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
		return $ c seqnum packet
	shasgen c i = do
		let (u:shas) = words $ T.unpack $ tagValue i
		return $ c (toUUID u) (mapMaybe extractSha shas)

decodeExitCode :: Int -> ExitCode
decodeExitCode 0 = ExitSuccess
decodeExitCode n = ExitFailure n

encodeExitCode :: ExitCode -> Int
encodeExitCode ExitSuccess = 0
encodeExitCode (ExitFailure n) = n

{- Base 64 encoding a ByteString to use as the content of a tag. -}
encodeTagContent :: ByteString -> [Node]
encodeTagContent b = [NodeContent $ ContentText $ T.pack $ B64.encode $ B.unpack b]

decodeTagContent :: Element -> Maybe ByteString
decodeTagContent elt = B.pack <$> B64.decode s
  where
	s = T.unpack $ T.concat $ elementText elt

{- The JID without the client part. -}
baseJID :: JID -> JID
baseJID j = JID (jidNode j) (jidDomain j) Nothing

{- An XMPP chat message with an empty body. This should not be displayed
 - by clients, but can be used for communications. -}
silentMessage :: Message
silentMessage = (emptyMessage MessageChat)
	{ messagePayloads = [ emptybody ] }
  where
	emptybody = Element
		{ elementName = "body"
		, elementAttributes = []
		, elementNodes = []
		}

{- Add to a presence to mark its client as extended away. -}
extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]

{- Add to a presence to give it a negative priority. -}
negativePriority :: Element
negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]

pushAttr :: Name
pushAttr = "push"

queryAttr :: Name
queryAttr = "query"

pairAttr :: Name
pairAttr = "pair"

canPushAttr :: Name
canPushAttr = "canpush"

pushRequestAttr :: Name
pushRequestAttr = "pushrequest"

startingPushAttr :: Name
startingPushAttr = "startingpush"

receivePackAttr :: Name
receivePackAttr = "rp"

sendPackAttr :: Name
sendPackAttr = "sp"

receivePackDoneAttr :: Name
receivePackDoneAttr = "rpdone"

shasAttr :: Name
shasAttr = "shas"


code:
{- xmpp buddies
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.XMPP.Buddies where

import Assistant.XMPP
import Common.Annex
import Assistant.Types.Buddies

import Network.Protocol.XMPP
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T

genBuddyKey :: JID -> BuddyKey
genBuddyKey j = BuddyKey $ formatJID $ baseJID j

buddyName :: JID -> Text
buddyName j = maybe (T.pack "") strNode (jidNode j)

ucFirst :: Text -> Text
ucFirst s = let (first, rest) = T.splitAt 1 s
	in T.concat [T.toUpper first, rest]

{- Summary of info about a buddy.
 -
 - If the buddy has no clients at all anymore, returns Nothing. -}
buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey)
buddySummary pairedwith b = case clients of
	((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j)
	[] -> Nothing
  where
	away = S.null (buddyPresent b) && S.null (buddyAssistants b)
	canpair = not $ S.null (buddyAssistants b)
	clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b
	alreadypaired j = baseJID j `elem` pairedwith

{- Updates the buddies with XMPP presence info. -}
updateBuddies :: Presence -> Buddies -> Buddies
updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
  where
	key = genBuddyKey jid
	update (Just b) = Just $ applyPresence p b
	update Nothing = newBuddy p
updateBuddies _ = id

{- Creates a new buddy based on XMPP presence info. -}
newBuddy :: Presence -> Maybe Buddy
newBuddy p
	| presenceType p == PresenceAvailable = go
	| presenceType p == PresenceUnavailable = go
	| otherwise = Nothing
  where
	go = make <$> presenceFrom p
	make _jid = applyPresence p $ Buddy
		{ buddyPresent = S.empty
		, buddyAway = S.empty
		, buddyAssistants = S.empty
		, buddyPairing = False
		}

applyPresence :: Presence -> Buddy -> Buddy
applyPresence p b = fromMaybe b $! go <$> presenceFrom p
  where
	go jid
		| presenceType p == PresenceUnavailable = b
			{ buddyAway = addto $ buddyAway b
			, buddyPresent = removefrom $ buddyPresent b
			, buddyAssistants = removefrom $ buddyAssistants b
			}
		| hasGitAnnexTag p = b
			{ buddyAssistants = addto $ buddyAssistants b
			, buddyAway = removefrom $ buddyAway b }
		| presenceType p == PresenceAvailable = b
			{ buddyPresent = addto $ buddyPresent b
			, buddyAway = removefrom $ buddyAway b
			}
		| otherwise = b
	  where
		client = Client jid
		removefrom = S.filter (/= client)
		addto = S.insert client


code:
{- xmpp client support
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.XMPP.Client where

import Assistant.Common
import Utility.SRV
import Creds

import Network.Protocol.XMPP
import Network
import Control.Concurrent
import qualified Data.Text as T
import Control.Exception (SomeException)

{- Everything we need to know to connect to an XMPP server. -}
data XMPPCreds = XMPPCreds
	{ xmppUsername :: T.Text
	, xmppPassword :: T.Text
	, xmppHostname :: HostName
	, xmppPort :: Int
	, xmppJID :: T.Text
	}
	deriving (Read, Show)

connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
connectXMPP c a = case parseJID (xmppJID c) of
	Nothing -> error "bad JID"
	Just jid -> connectXMPP' jid c a

{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
connectXMPP' jid c a = reverse <$> (handle =<< lookupSRV srvrecord)
  where
	srvrecord = mkSRVTcp "xmpp-client" $
		T.unpack $ strDomain $ jidDomain jid
	serverjid = JID Nothing (jidDomain jid) Nothing

	handle [] = do
		let h = xmppHostname c
		let p = PortNumber $ fromIntegral $ xmppPort c
		r <- run h p $ a jid
		return [r]
	handle srvs = go [] srvs

	go l [] = return l
	go l ((h,p):rest) = do
		{- Try each SRV record in turn, until one connects,
		 - at which point the MVar will be full. -}
		mv <- newEmptyMVar
		r <- run h p $ do
			liftIO $ putMVar mv ()
			a jid
		ifM (isEmptyMVar mv)
			( go (r : l) rest
			, return (r : l)
			)

	{- Async exceptions are let through so the XMPP thread can
	 - be killed. -}
	run h p a' = do
		r <- tryNonAsync $
			runClientError (Server serverjid h p) jid
				(xmppUsername c) (xmppPassword c) (void a')
		return ((h, p), r)

{- XMPP runClient, that throws errors rather than returning an Either -}
runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
runClientError s j u p x = either (error . show) return =<< runClient s j u p x

getXMPPCreds :: Annex (Maybe XMPPCreds)
getXMPPCreds = parse <$> readCacheCreds xmppCredsFile
  where
	parse s = readish =<< s

setXMPPCreds :: XMPPCreds -> Annex ()
setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile

xmppCredsFile :: FilePath
xmppCredsFile = "xmpp"


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

{-# LANGUAGE CPP #-}

module Assistant.XMPP.Git where

import Assistant.Common
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.XMPP
import Assistant.XMPP.Buddies
import Assistant.DaemonStatus
import Assistant.Alert
import Assistant.MakeRemote
import Assistant.Sync
import qualified Command.Sync
import qualified Annex.Branch
import Annex.UUID
import Logs.UUID
import Annex.TaggedPush
import Annex.CatFile
import Config
import Git
import qualified Git.Branch
import Config.Files
import qualified Types.Remote as Remote
import qualified Remote as Remote
import Remote.List
import Utility.FileMode
import Utility.Shell
import Utility.Env

import Network.Protocol.XMPP
import qualified Data.Text as T
import System.Posix.Types
import Control.Concurrent
import System.Timeout
import qualified Data.ByteString as B
import qualified Data.Map as M

{- Largest chunk of data to send in a single XMPP message. -}
chunkSize :: Int
chunkSize = 4096

{- How long to wait for an expected message before assuming the other side
 - has gone away and canceling a push.
 -
 - This needs to be long enough to allow a message of up to 2+ times
 - chunkSize to propigate up to a XMPP server, perhaps across to another
 - server, and back down to us. On the other hand, other XMPP pushes can be
 - delayed for running until the timeout is reached, so it should not be
 - excessive.
 -}
xmppTimeout :: Int
xmppTimeout = 120000000 -- 120 seconds

finishXMPPPairing :: JID -> UUID -> Assistant ()
finishXMPPPairing jid u = void $ alertWhile alert $
	makeXMPPGitRemote buddy (baseJID jid) u
  where
	buddy = T.unpack $ buddyName jid
	alert = pairRequestAcknowledgedAlert buddy Nothing

gitXMPPLocation :: JID -> String
gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)

makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
makeXMPPGitRemote buddyname jid u = do
	remote <- liftAnnex $ addRemote $
		makeGitRemote buddyname $ gitXMPPLocation jid
	liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u
	liftAnnex $ void remoteListRefresh
	remote' <- liftAnnex $ fromMaybe (error "failed to add remote")
		<$> Remote.byName (Just buddyname)
	syncRemote remote'
	return True

{- Pushes over XMPP, communicating with a specific client.
 - Runs an arbitrary IO action to push, which should run git-push with
 - an xmpp:: url.
 -
 - To handle xmpp:: urls, git push will run git-remote-xmpp, which is
 - injected into its PATH, and in turn runs git-annex xmppgit. The
 - dataflow them becomes:
 -
 - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
 -                                                          |
 - git receive-pack <--> xmppReceivePack <---------------> xmpp
 -
 - The pipe between git-annex xmppgit and us is set up and communicated
 - using two environment variables, relayIn and relayOut, that are set
 - to the file descriptors to use. Another, relayControl, is used to
 - propigate the exit status of git receive-pack.
 -
 - We listen at the other end of the pipe and relay to and from XMPP.
 -}
xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
xmppPush cid gitpush = do
	u <- liftAnnex getUUID
	sendNetMessage $ Pushing cid (StartingPush u)

	(Fd inf, writepush) <- liftIO createPipe
	(readpush, Fd outf) <- liftIO createPipe
	(Fd controlf, writecontrol) <- liftIO createPipe

	tmpdir <- gettmpdir
	installwrapper tmpdir

	environ <- liftIO getEnvironment
	path <- liftIO getSearchPath
	let myenviron = addEntries
		[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
		, (relayIn, show inf)
		, (relayOut, show outf)
		, (relayControl, show controlf)
		]
		environ

	inh <- liftIO $ fdToHandle readpush
	outh <- liftIO $ fdToHandle writepush
	controlh <- liftIO $ fdToHandle writecontrol

	t1 <- forkIO <~> toxmpp 0 inh
	t2 <- forkIO <~> fromxmpp outh controlh

	{- This can take a long time to run, so avoid running it in the
	 - Annex monad. Also, override environment. -}
	g <- liftAnnex gitRepo
	r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }

	liftIO $ do
		mapM_ killThread [t1, t2]
		mapM_ hClose [inh, outh, controlh]
		mapM_ closeFd [Fd inf, Fd outf, Fd controlf]

	return r
  where
	toxmpp seqnum inh = do
		b <- liftIO $ B.hGetSome inh chunkSize
		if B.null b
			then liftIO $ killThread =<< myThreadId
			else do
				let seqnum' = succ seqnum
				sendNetMessage $ Pushing cid $
					SendPackOutput seqnum' b
				toxmpp seqnum' inh

	fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handle
	  where
	  	handle (Just (Pushing _ (ReceivePackOutput _ b))) =
			liftIO $ writeChunk outh b
		handle (Just (Pushing _ (ReceivePackDone exitcode))) =
			liftIO $ do
				hPrint controlh exitcode
				hFlush controlh
		handle (Just _) = noop
		handle Nothing = do
			debug ["timeout waiting for git receive-pack output via XMPP"]
			-- Send a synthetic exit code to git-annex
			-- xmppgit, which will exit and cause git push
			-- to die.
			liftIO $ do
				hPrint controlh (ExitFailure 1)
				hFlush controlh
				killThread =<< myThreadId

	installwrapper tmpdir = liftIO $ do
		createDirectoryIfMissing True tmpdir
		let wrapper = tmpdir </> "git-remote-xmpp"
		program <- readProgramFile
		writeFile wrapper $ unlines
			[ shebang_local
			, "exec " ++ program ++ " xmppgit"
			]
		modifyFileMode wrapper $ addModes executeModes

	{- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp
	 - dir (ie, not on a crippled filesystem where we can't make
	 - the wrapper executable). -}
	gettmpdir = do
		v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
		case v of
			Nothing -> do
				tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir
				return $ tmp </> "xmppgit"
			Just d -> return $ d </> "xmppgit"

type EnvVar = String

envVar :: String -> EnvVar
envVar s = "GIT_ANNEX_XMPPGIT_" ++ s

relayIn :: EnvVar
relayIn = envVar "IN"

relayOut :: EnvVar
relayOut = envVar "OUT"

relayControl :: EnvVar
relayControl = envVar "CONTROL"

relayHandle :: EnvVar -> IO Handle
relayHandle var = do
	v <- getEnv var
	case readish =<< v of
		Nothing -> error $ var ++ " not set"
		Just n -> fdToHandle $ Fd n

{- Called by git-annex xmppgit.
 -
 - git-push is talking to us on stdin
 - we're talking to git-push on stdout
 - git-receive-pack is talking to us on relayIn (via XMPP)
 - we're talking to git-receive-pack on relayOut (via XMPP)
 - git-receive-pack's exit code will be passed to us on relayControl
 -}
xmppGitRelay :: IO ()
xmppGitRelay = do
	flip relay stdout =<< relayHandle relayIn
	relay stdin =<< relayHandle relayOut
	code <- hGetLine =<< relayHandle relayControl
	exitWith $ fromMaybe (ExitFailure 1) $ readish code
  where
	{- Is it possible to set up pipes and not need to copy the data
	 - ourselves? See splice(2) -}
	relay fromh toh = void $ forkIO $ forever $ do
		b <- B.hGetSome fromh chunkSize
		when (B.null b) $ do
			hClose fromh
			hClose toh
			killThread =<< myThreadId
		writeChunk toh b

{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
 - its exit status to XMPP. -}
xmppReceivePack :: ClientID -> Assistant Bool
xmppReceivePack cid = do
	repodir <- liftAnnex $ fromRepo repoPath
	let p = (proc "git" ["receive-pack", repodir])
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = Inherit
		}
	(Just inh, Just outh, _, pid) <- liftIO $ createProcess p
	readertid <- forkIO <~> relayfromxmpp inh
	relaytoxmpp 0 outh
	code <- liftIO $ waitForProcess pid
	void $ sendNetMessage $ Pushing cid $ ReceivePackDone code
	liftIO $ do
		killThread readertid
		hClose inh
		hClose outh
		return $ code == ExitSuccess
  where
	relaytoxmpp seqnum outh = do
		b <- liftIO $ B.hGetSome outh chunkSize
		-- empty is EOF, so exit
		unless (B.null b) $ do
			let seqnum' = succ seqnum
			sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b
			relaytoxmpp seqnum' outh
	relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handle
	  where
	  	handle (Just (Pushing _ (SendPackOutput _ b))) =
			liftIO $ writeChunk inh b
		handle (Just _) = noop
		handle Nothing = do
			debug ["timeout waiting for git send-pack output via XMPP"]
			-- closing the handle will make git receive-pack exit
			liftIO $ do
				hClose inh
				killThread =<< myThreadId

xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
	Nothing -> return []
	Just jid -> do
		let loc = gitXMPPLocation jid
		um <- liftAnnex uuidMap
		filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes
			<$> getDaemonStatus
  where
	matching loc r = repoIsUrl r && repoLocation r == loc
	knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um

{- Returns the ClientID that it pushed to. -}
runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
	go =<< liftAnnex (inRepo Git.Branch.current)
  where
	go Nothing = return Nothing
	go (Just branch) = do
		rs <- xmppRemotes cid theiruuid
		liftAnnex $ Annex.Branch.commit "update"
		(g, u) <- liftAnnex $ (,)
			<$> gitRepo
			<*> getUUID
		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
		if null rs
			then return Nothing
			else do
				forM_ rs $ \r -> do
					void $ alertWhile (syncAlert [r]) $
						xmppPush cid (taggedPush u selfjid branch r)
					checkcloudrepos r
				return $ Just cid
runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
	rs <- xmppRemotes cid theiruuid
	if null rs
		then return Nothing
		else do
			void $ alertWhile (syncAlert rs) $
				xmppReceivePack cid
			mapM_ checkcloudrepos rs
			return $ Just cid
runPush _ _ = return Nothing

{- Check if any of the shas that can be pushed are ones we do not
 - have.
 -
 - (Older clients send no shas, so when there are none, always
 - request a push.)
 -}
handlePushNotice :: NetMessage -> Assistant ()
handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
	unlessM (null <$> xmppRemotes cid theiruuid) $
		if null shas
			then go
			else ifM (haveall shas)
				( debug ["ignoring CanPush with known shas"]
				, go
				)
  where
  	go = do
		u <- liftAnnex getUUID
		sendNetMessage $ Pushing cid (PushRequest u)
	haveall l = liftAnnex $ not <$> anyM donthave l
	donthave sha = isNothing <$> catObjectDetails sha
handlePushNotice _ = noop

writeChunk :: Handle -> B.ByteString -> IO ()
writeChunk h b = do
	B.hPut h b
	hFlush h

{- Gets NetMessages for a PushSide, ensures they are in order,
 - and runs an action to handle each in turn. The action will be passed
 - Nothing on timeout.
 -
 - Does not currently reorder messages, but does ensure that any
 - duplicate messages, or messages not in the sequence, are discarded.
 -}
withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()
withPushMessagesInSequence cid side a = loop 0
  where
  	loop seqnum = do
		m <- timeout xmppTimeout <~> waitInbox cid side
	  	let go s = a m >> loop s
		let next = seqnum + 1
		case extractSequence =<< m of
			Just seqnum'
				| seqnum' == next -> go next
				| seqnum' == 0 -> go seqnum
				| seqnum' == seqnum -> do
					debug ["ignoring duplicate sequence number", show seqnum]
					loop seqnum
				| otherwise -> do
					debug ["ignoring out of order sequence number", show seqnum', "expected", show next]
					loop seqnum
			Nothing -> go seqnum

extractSequence :: NetMessage -> Maybe Int
extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum
extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum
extractSequence _ = Nothing


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

module Backend (
	list,
	orderedList,
	genKey,
	lookupFile,
	getBackend,
	isAnnexLink,
	chooseBackend,
	lookupBackendName,
	maybeLookupBackendName,
	isStableKey,
) where

import Common.Annex
import qualified Annex
import Annex.CheckAttr
import Annex.CatFile
import Annex.Link
import Types.Key
import Types.KeySource
import qualified Types.Backend as B
import Config

-- When adding a new backend, import it here and add it to the list.
import qualified Backend.Hash
import qualified Backend.WORM
import qualified Backend.URL

import qualified Data.Map as M

list :: [Backend]
list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends

{- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend]
orderedList = do
	l <- Annex.getState Annex.backends -- list is cached here
	if not $ null l
		then return l
		else do
			f <- Annex.getState Annex.forcebackend
			case f of
				Just name | not (null name) ->
					return [lookupBackendName name]
				_ -> do
					l' <- gen . annexBackends <$> Annex.getGitConfig
					Annex.changeState $ \s -> s { Annex.backends = l' }
					return l'
  where
	gen [] = list
	gen l = map lookupBackendName l

{- Generates a key for a file, trying each backend in turn until one
 - accepts it. -}
genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))
genKey source trybackend = do
	bs <- orderedList
	let bs' = maybe bs (: bs) trybackend
	genKey' bs' source
genKey' :: [Backend] -> KeySource -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing
genKey' (b:bs) source = do
	r <- B.getKey b source
	case r of
		Nothing -> genKey' bs source
		Just k -> return $ Just (makesane k, b)
  where
	-- keyNames should not contain newline characters.
	makesane k = k { keyName = map fixbadchar (keyName k) }
	fixbadchar c
		| c == '\n' = '_'
		| otherwise = c

{- Looks up the key corresponding to an annexed file,
 - by examining what the file links to.
 -
 - In direct mode, there is often no link on disk, in which case
 - the symlink is looked up in git instead. However, a real link
 - on disk still takes precedence over what was committed to git in direct
 - mode.
 -}
lookupFile :: FilePath -> Annex (Maybe Key)
lookupFile file = do
	mkey <- isAnnexLink file
	case mkey of
		Just key -> makeret key
		Nothing -> ifM isDirect
			( maybe (return Nothing) makeret =<< catKeyFile file
			, return Nothing
			)
  where
	makeret k = return $ Just k

getBackend :: FilePath -> Key -> Annex (Maybe Backend)
getBackend file k = let bname = keyBackendName k in
	case maybeLookupBackendName bname of
		Just backend -> return $ Just backend
		Nothing -> do
			warning $ "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")"
			return Nothing

{- Looks up the backend that should be used for a file.
 - That can be configured on a per-file basis in the gitattributes file. -}
chooseBackend :: FilePath -> Annex (Maybe Backend)
chooseBackend f = Annex.getState Annex.forcebackend >>= go
  where
	go Nothing =  maybeLookupBackendName <$> checkAttr "annex.backend" f
	go (Just _) = Just . Prelude.head <$> orderedList

{- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
  where
	unknown = error $ "unknown backend " ++ s

maybeLookupBackendName :: String -> Maybe Backend
maybeLookupBackendName s = M.lookup s nameMap

nameMap :: M.Map String Backend
nameMap = M.fromList $ zip (map B.name list) list

isStableKey :: Key -> Bool
isStableKey k = maybe False (`B.isStableKey` k)
	(maybeLookupBackendName (keyBackendName k))


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

{-# LANGUAGE CPP #-}

module Backend.Hash (
	backends,
	testKeyBackend,
) where

import Common.Annex
import qualified Annex
import Types.Backend
import Types.Key
import Types.KeySource
import Utility.Hash
import Utility.ExternalSHA

import qualified Build.SysConfig as SysConfig
import qualified Data.ByteString.Lazy as L
import Data.Char

data Hash = SHAHash HashSize | SkeinHash HashSize
type HashSize = Int

{- Order is slightly significant; want SHA256 first, and more general
 - sizes earlier. -}
hashes :: [Hash]
hashes = concat
	[ map SHAHash [256, 1, 512, 224, 384]
#ifdef WITH_CRYPTOHASH
	, map SkeinHash [256, 512]
#endif
	]

{- The SHA256E backend is the default, so genBackendE comes first. -}
backends :: [Backend]
backends = map genBackendE hashes ++ map genBackend hashes

genBackend :: Hash -> Backend
genBackend hash = Backend
	{ name = hashName hash
	, getKey = keyValue hash
	, fsckKey = Just $ checkKeyChecksum hash
	, canUpgradeKey = Just needsUpgrade
	, fastMigrate = Just trivialMigrate
	, isStableKey = const True
	}

genBackendE :: Hash -> Backend
genBackendE hash = (genBackend hash)
	{ name = hashNameE hash
	, getKey = keyValueE hash
	}

hashName :: Hash -> String
hashName (SHAHash size) = "SHA" ++ show size
hashName (SkeinHash size) = "SKEIN" ++ show size

hashNameE :: Hash -> String
hashNameE hash = hashName hash ++ "E"

{- A key is a hash of its contents. -}
keyValue :: Hash -> KeySource -> Annex (Maybe Key)
keyValue hash source = do
	let file = contentLocation source
	stat <- liftIO $ getFileStatus file
	let filesize = fromIntegral $ fileSize stat
	s <- hashFile hash file filesize
	return $ Just $ stubKey
		{ keyName = s
		, keyBackendName = hashName hash
		, keySize = Just filesize
		}

{- Extension preserving keys. -}
keyValueE :: Hash -> KeySource -> Annex (Maybe Key)
keyValueE hash source = keyValue hash source >>= maybe (return Nothing) addE
  where
	addE k = return $ Just $ k
		{ keyName = keyName k ++ selectExtension (keyFilename source)
		, keyBackendName = hashNameE hash
		}

selectExtension :: FilePath -> String
selectExtension f
	| null es = ""
	| otherwise = intercalate "." ("":es)
  where
	es = filter (not . null) $ reverse $
		take 2 $ takeWhile shortenough $
		reverse $ split "." $ filter validExtension $ takeExtensions f
	shortenough e = length e <= 4 -- long enough for "jpeg"

{- A key's checksum is checked during fsck. -}
checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool
checkKeyChecksum hash key file = do
	fast <- Annex.getState Annex.fast
	mstat <- liftIO $ catchMaybeIO $ getFileStatus file
	case (mstat, fast) of
		(Just stat, False) -> do
			let filesize = fromIntegral $ fileSize stat
			showSideAction "checksum"
			check <$> hashFile hash file filesize
		_ -> return True
  where
	expected = keyHash key
	check s
		| s == expected = True
		{- A bug caused checksums to be prefixed with \ in some
		 - cases; still accept these as legal now that the bug has been
		 - fixed. -}
		| '\\' : s == expected = True
		| otherwise = False

keyHash :: Key -> String
keyHash key = dropExtensions (keyName key)

validExtension :: Char -> Bool
validExtension c
	| isAlphaNum c = True
	| c == '.' = True
	| otherwise = False

{- Upgrade keys that have the \ prefix on their sha due to a bug, or
 - that contain non-alphanumeric characters in their extension. -}
needsUpgrade :: Key -> Bool
needsUpgrade key = "\\" `isPrefixOf` keyHash key ||
	any (not . validExtension) (takeExtensions $ keyName key)

{- Fast migration from hashE to hash backend. (Optimisation) -}
trivialMigrate :: Key -> Backend -> Maybe Key
trivialMigrate oldkey newbackend
	| keyBackendName oldkey == name newbackend ++ "E" = Just $ oldkey
		{ keyName = keyHash oldkey
		, keyBackendName = name newbackend
		}
	| otherwise = Nothing

hashFile :: Hash -> FilePath -> Integer -> Annex String
hashFile hash file filesize = liftIO $ go hash
  where
  	go (SHAHash hashsize) = case shaHasher hashsize filesize of
		Left sha -> sha <$> L.readFile file
		Right command ->
			either error return
				=<< externalSHA command hashsize file
	go (SkeinHash hashsize) = skeinHasher hashsize <$> L.readFile file

shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) String
shaHasher hashsize filesize
	| hashsize == 1 = use SysConfig.sha1 sha1
	| hashsize == 256 = use SysConfig.sha256 sha256
	| hashsize == 224 = use SysConfig.sha224 sha224
	| hashsize == 384 = use SysConfig.sha384 sha384
	| hashsize == 512 = use SysConfig.sha512 sha512
	| otherwise = error $ "unsupported sha size " ++ show hashsize
  where
	use Nothing hasher = Left $ show . hasher
	use (Just c) hasher
		{- Use builtin, but slightly slower hashing for
		 - smallish files. Cryptohash benchmarks 90 to 101%
		 - faster than external hashers, depending on the hash
		 - and system. So there is no point forking an external
		 - process unless the file is large. -}
		| filesize < 1048576 = use Nothing hasher
		| otherwise = Right c

skeinHasher :: HashSize -> (L.ByteString -> String)
skeinHasher hashsize
#ifdef WITH_CRYPTOHASH
	| hashsize == 256 = show . skein256
	| hashsize == 512 = show . skein512
#endif
	| otherwise = error $ "unsupported skein size " ++ show hashsize

{- A varient of the SHA256E backend, for testing that needs special keys
 - that cannot collide with legitimate keys in the repository.
 -
 - This is accomplished by appending a special extension to the key,
 - that is not one that selectExtension would select (due to being too
 - long).
 -}
testKeyBackend :: Backend
testKeyBackend =
	let b = genBackendE (SHAHash 256)
	in b { getKey = (fmap addE) <$$> getKey b }
  where
	addE k = k { keyName = keyName k ++ longext }
	longext = ".this-is-a-test-key"