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

{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Assistant.Threads.WebApp where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Configurators.AWS
import Assistant.WebApp.Configurators.IA
import Assistant.WebApp.Configurators.WebDAV
import Assistant.WebApp.Configurators.XMPP
import Assistant.WebApp.Configurators.Preferences
import Assistant.WebApp.Configurators.Unused
import Assistant.WebApp.Configurators.Edit
import Assistant.WebApp.Configurators.Delete
import Assistant.WebApp.Configurators.Fsck
import Assistant.WebApp.Configurators.Upgrade
import Assistant.WebApp.Documentation
import Assistant.WebApp.Control
import Assistant.WebApp.OtherRepos
import Assistant.WebApp.Repair
import Assistant.Types.ThreadedMonad
import Utility.WebApp
import Utility.Tmp
import Utility.FileMode
import Git
import qualified Annex

import Yesod
import Network.Socket (SockAddr, HostName)
import Data.Text (pack, unpack)
import qualified Network.Wai.Handler.WarpTLS as TLS
import Network.Wai.Middleware.RequestLogger
import System.Log.Logger

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

type Url = String

webAppThread
	:: AssistantData
	-> UrlRenderer
	-> Bool
	-> Maybe String
	-> Maybe (IO Url)
	-> Maybe HostName
	-> Maybe (Url -> FilePath -> IO ())
	-> NamedThread
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do
	listenhost' <- if isJust listenhost
		then pure listenhost
		else getAnnex $ annexListen <$> Annex.getGitConfig
	tlssettings <- getAnnex getTlsSettings
#ifdef __ANDROID__
	when (isJust listenhost') $
		-- See Utility.WebApp
		error "Sorry, --listen is not currently supported on Android"
#endif
	webapp <- WebApp
		<$> pure assistantdata
		<*> genAuthToken
		<*> getreldir
		<*> pure staticRoutes
		<*> pure postfirstrun
		<*> pure cannotrun
		<*> pure noannex
		<*> pure listenhost'
	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
	app <- toWaiAppPlain webapp
	app' <- ifM debugEnabled
		( return $ logStdout app
		, return app
		)
	runWebApp tlssettings listenhost' app' $ \addr -> if noannex
		then withTmpFile "webapp.html" $ \tmpfile h -> do
			hClose h
			go tlssettings addr webapp tmpfile Nothing
		else do
			htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
			urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
			go tlssettings addr webapp htmlshim (Just urlfile)
  where
  	-- The webapp thread does not wait for the startupSanityCheckThread
	-- to finish, so that the user interface remains responsive while
	-- that's going on.
	thread = namedThreadUnchecked "WebApp"
	getreldir
		| noannex = return Nothing
		| otherwise = Just <$>
			(relHome =<< absPath
				=<< getAnnex' (fromRepo repoPath))
	go tlssettings addr webapp htmlshim urlfile = do
		let url = myUrl tlssettings webapp addr
		maybe noop (`writeFileProtected` url) urlfile
		writeHtmlShim "Starting webapp..." url htmlshim
		maybe noop (\a -> a url htmlshim) onstartup

	getAnnex a
		| noannex = pure Nothing
		| otherwise = getAnnex' a
	getAnnex' = runThreadState (threadState assistantdata)

myUrl :: Maybe TLS.TLSSettings -> WebApp -> SockAddr -> Url
myUrl tlssettings webapp addr = unpack $ yesodRender webapp urlbase DashboardR []
  where
	urlbase = pack $ proto ++ "://" ++ show addr
	proto
		| isJust tlssettings = "https"
		| otherwise = "http"

getTlsSettings :: Annex (Maybe TLS.TLSSettings)
getTlsSettings = do
#ifdef WITH_WEBAPP_SECURE
	cert <- fromRepo gitAnnexWebCertificate
	privkey <- fromRepo gitAnnexWebPrivKey
	ifM (liftIO $ allM doesFileExist [cert, privkey])
		( return $ Just $ TLS.tlsSettings cert privkey
		, return Nothing
		)
#else
	return Nothing
#endif

{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
debugEnabled = do
	l <- getRootLogger
	return $ getLevel l <= Just DEBUG


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

module Assistant.Threads.XMPPClient where

import Assistant.Common
import Assistant.XMPP
import Assistant.XMPP.Client
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.Types.Buddies
import Assistant.XMPP.Buddies
import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
import Assistant.WebApp (UrlRenderer)
import Assistant.WebApp.Types hiding (liftAssistant)
import Assistant.Alert
import Assistant.Pairing
import Assistant.XMPP.Git
import Annex.UUID
import Logs.UUID

import Network.Protocol.XMPP
import Control.Concurrent
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM (atomically)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Git.Branch
import Data.Time.Clock
import Control.Concurrent.Async

xmppClientThread :: UrlRenderer -> NamedThread
xmppClientThread urlrenderer = namedThread "XMPPClient" $
	restartableClient . xmppClient urlrenderer =<< getAssistant id

{- Runs the client, handing restart events. -}
restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()
restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
  where
	go Nothing = waitNetMessagerRestart
	go (Just creds) = do
		xmppuuid <- maybe NoUUID Remote.uuid . headMaybe
			. filter Remote.isXMPPRemote . syncRemotes
			<$> getDaemonStatus
		tid <- liftIO $ forkIO $ a creds xmppuuid
		waitNetMessagerRestart
		liftIO $ killThread tid

xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()
xmppClient urlrenderer d creds xmppuuid =
	retry (runclient creds) =<< getCurrentTime
  where
	liftAssistant = runAssistant d
	inAssistant = liftIO . liftAssistant

	{- When the client exits, it's restarted;
	 - if it keeps failing, back off to wait 5 minutes before
	 - trying it again. -}
	retry client starttime = do
		{- The buddy list starts empty each time
		 - the client connects, so that stale info
		 - is not retained. -}
		liftAssistant $
			updateBuddyList (const noBuddies) <<~ buddyList
		void client
		liftAssistant $ do
			modifyDaemonStatus_ $ \s -> s
				{ xmppClientID = Nothing }
			changeCurrentlyConnected $ S.delete xmppuuid

		now <- getCurrentTime
		if diffUTCTime now starttime > 300
			then do
				liftAssistant $ debug ["connection lost; reconnecting"]
				retry client now
			else do
				liftAssistant $ debug ["connection failed; will retry"]
				threadDelaySeconds (Seconds 300)
				retry client =<< getCurrentTime

	runclient c = liftIO $ connectXMPP c $ \jid -> do
		selfjid <- bindJID jid
		putStanza gitAnnexSignature

		inAssistant $ do
			modifyDaemonStatus_ $ \s -> s
				{ xmppClientID = Just $ xmppJID creds }
			changeCurrentlyConnected $ S.insert xmppuuid
			debug ["connected", logJid selfjid]

		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime

		sender <- xmppSession $ sendnotifications selfjid
		receiver <- xmppSession $ receivenotifications selfjid lasttraffic
		pinger <- xmppSession $ sendpings selfjid lasttraffic
		{- Run all 3 threads concurrently, until
		 - any of them throw an exception.
		 - Then kill all 3 threads, and rethrow the
		 - exception.
		 -
		 - If this thread gets an exception, the 3 threads
		 - will also be killed. -}
		liftIO $ pinger `concurrently` sender `concurrently` receiver

	sendnotifications selfjid = forever $
		join $ inAssistant $ relayNetMessage selfjid
	receivenotifications selfjid lasttraffic = forever $ do
		l <- decodeStanza selfjid <$> getStanza
		void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
		inAssistant $ debug
			["received:", show $ map logXMPPEvent l]
		mapM_ (handle selfjid) l
	sendpings selfjid lasttraffic = forever $ do
		putStanza pingstanza

		startping <- liftIO getCurrentTime
		liftIO $ threadDelaySeconds (Seconds 120)
		t <- liftIO $ atomically $ readTMVar lasttraffic
		when (t < startping) $ do
			inAssistant $ debug ["ping timeout"]
			error "ping timeout"
	  where
		{- XEP-0199 says that the server will respond with either
		 - a ping response or an error message. Either will
		 - cause traffic, so good enough. -}
	  	pingstanza = xmppPing selfjid

	handle selfjid (PresenceMessage p) = do
		void $ inAssistant $
			updateBuddyList (updateBuddies p) <<~ buddyList
		resendImportantMessages selfjid p
	handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
	handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
	handle selfjid (GotNetMessage (PairingNotification stage c u)) =
		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
	handle _ (GotNetMessage m@(Pushing _ pushstage))
		| isPushNotice pushstage = inAssistant $ handlePushNotice m
		| isPushInitiation pushstage = inAssistant $ queuePushInitiation m
		| otherwise = inAssistant $ storeInbox m
	handle _ (Ignorable _) = noop
	handle _ (Unknown _) = noop
	handle _ (ProtocolError _) = noop

	resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
		let c = formatJID jid
		(stored, sent) <- inAssistant $
			checkImportantNetMessages (formatJID (baseJID jid), c)
		forM_ (S.toList $ S.difference stored sent) $ \msg -> do
			let msg' = readdressNetMessage msg c
			inAssistant $ debug
				[ "sending to new client:"
				, logJid jid
				, show $ logNetMessage msg'
				]
			join $ inAssistant $ convertNetMsg msg' selfjid
			inAssistant $ sentImportantNetMessage msg c
	resendImportantMessages _ _ = noop

data XMPPEvent
	= GotNetMessage NetMessage
	| PresenceMessage Presence
	| Ignorable ReceivedStanza
	| Unknown ReceivedStanza
	| ProtocolError ReceivedStanza
	deriving Show

logXMPPEvent :: XMPPEvent -> String
logXMPPEvent (GotNetMessage m) = logNetMessage m
logXMPPEvent (PresenceMessage p) = logPresence p
logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
logXMPPEvent (Ignorable _) = "Ignorable message"
logXMPPEvent (Unknown _) = "Unknown message"
logXMPPEvent (ProtocolError _) = "Protocol error message"

logPresence :: Presence -> String
logPresence (p@Presence { presenceFrom = Just jid }) = unwords
	[ "Presence from"
	, logJid jid
	, show $ extractGitAnnexTag p
	]
logPresence _ = "Presence from unknown"

logJid :: JID -> String
logJid jid =
	let name = T.unpack (buddyName jid)
	    resource = maybe "" (T.unpack . strResource) (jidResource jid)
	in take 1 name ++ show (length name) ++ "/" ++ resource

logClient :: Client -> String
logClient (Client jid) = logJid jid

{- Decodes an XMPP stanza into one or more events. -}
decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
decodeStanza selfjid s@(ReceivedPresence p)
	| presenceType p == PresenceError = [ProtocolError s]
	| isNothing (presenceFrom p) = [Ignorable s]
	| presenceFrom p == Just selfjid = [Ignorable s]
	| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
  where
	decode i
		| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
			decodePushNotification (tagValue i)
		| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
		| otherwise = [Unknown s]
	{- Things sent via presence imply a presence message,
	 - along with their real meaning. -}
	impliedp v = [PresenceMessage p, v]
decodeStanza selfjid s@(ReceivedMessage m)
	| isNothing (messageFrom m) = [Ignorable s]
	| messageFrom m == Just selfjid = [Ignorable s]
	| messageType m == MessageError = [ProtocolError s]
	| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
decodeStanza _ s = [Unknown s]

{- Waits for a NetMessager message to be sent, and relays it to XMPP.
 -
 - Chat messages must be directed to specific clients, not a base
 - account JID, due to git-annex clients using a negative presence priority.
 - PairingNotification messages are always directed at specific
 - clients, but Pushing messages are sometimes not, and need to be exploded
 - out to specific clients.
 -
 - Important messages, not directed at any specific client,
 - are cached to be sent later when additional clients connect.
 -}
relayNetMessage :: JID -> Assistant (XMPP ())
relayNetMessage selfjid = do
	msg <- waitNetMessage
	debug ["sending:", logNetMessage msg]
	a1 <- handleImportant msg
	a2 <- convert msg
	return (a1 >> a2)
  where
	handleImportant msg = case parseJID =<< isImportantNetMessage msg of
		Just tojid
			| tojid == baseJID tojid -> do
				storeImportantNetMessage msg (formatJID tojid) $
					\c -> (baseJID <$> parseJID c) == Just tojid
				return $ putStanza presenceQuery
		_ -> return noop
	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
		if tojid == baseJID tojid
			then do
				clients <- maybe [] (S.toList . buddyAssistants)
					<$> getBuddy (genBuddyKey tojid) <<~ buddyList
				debug ["exploded undirected message to clients", unwords $ map logClient clients]
				return $ forM_ clients $ \(Client jid) ->
					putStanza $ pushMessage pushstage jid selfjid
			else do
				debug ["to client:", logJid tojid]
				return $ putStanza $ pushMessage pushstage tojid selfjid
	convert msg = convertNetMsg msg selfjid

{- Converts a NetMessage to an XMPP action. -}
convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())
convertNetMsg msg selfjid = convert msg
  where
	convert (NotifyPush us) = return $ putStanza $ pushNotification us
	convert QueryPresence = return $ putStanza presenceQuery
	convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do
		changeBuddyPairing tojid True
		return $ putStanza $ pairingNotification stage u tojid selfjid
	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
		return $ putStanza $  pushMessage pushstage tojid selfjid

withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ())
withOtherClient selfjid c a = case parseJID c of
	Nothing -> return noop
	Just tojid
		| tojid == selfjid -> return noop
		| otherwise -> a tojid

withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
withClient c a = maybe noop a $ parseJID c

{- Returns an IO action that runs a XMPP action in a separate thread,
 - using a session to allow it to access the same XMPP client. -}
xmppSession :: XMPP () -> XMPP (IO ())
xmppSession a = do
	s <- getSession
	return $ void $ runXMPP s a

{- We only pull from one remote out of the set listed in the push
 - notification, as an optimisation.
 -
 - Note that it might be possible (though very unlikely) for the push
 - notification to take a while to be sent, and multiple pushes happen
 - before it is sent, so it includes multiple remotes that were pushed
 - to at different times.
 -
 - It could then be the case that the remote we choose had the earlier
 - push sent to it, but then failed to get the later push, and so is not
 - fully up-to-date. If that happens, the pushRetryThread will come along
 - and retry the push, and we'll get another notification once it succeeds,
 - and pull again. -}
pull :: [UUID] -> Assistant ()
pull [] = noop
pull us = do
	rs <- filter matching . syncGitRemotes <$> getDaemonStatus
	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
	pullone rs =<< liftAnnex (inRepo Git.Branch.current)
  where
	matching r = Remote.uuid r `S.member` s
	s = S.fromList us

	pullone [] _ = noop
	pullone (r:rs) branch =
		unlessM (null . fst <$> manualPull branch [r]) $
			pullone rs branch

{- PairReq from another client using our JID is automatically
 - accepted. This is so pairing devices all using the same XMPP
 - account works without confirmations.
 -
 - Also, autoaccept PairReq from the same JID of any repo we've
 - already paired with, as long as the UUID in the PairReq is
 - one we know about.
-}
pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
	| baseJID selfjid == baseJID theirjid = autoaccept
	| otherwise = do
		knownjids <- mapMaybe (parseJID . getXMPPClientID)
			. filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus
		um <- liftAnnex uuidMap
		if elem (baseJID theirjid) knownjids && M.member theiruuid um
			then autoaccept
			else showalert

  where
	autoaccept = do
		selfuuid <- liftAnnex getUUID
		sendNetMessage $
			PairingNotification PairAck (formatJID theirjid) selfuuid
		finishXMPPPairing theirjid theiruuid
	-- Show an alert to let the user decide if they want to pair.
	showalert = do
		button <- mkAlertButton True (T.pack "Respond") urlrenderer $
			ConfirmXMPPPairFriendR $
				PairKey theiruuid $ formatJID theirjid
		void $ addAlert $ pairRequestReceivedAlert
			(T.unpack $ buddyName theirjid)
			button

{- PairAck must come from one of the buddies we are pairing with;
 - don't pair with just anyone. -}
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
	whenM (isBuddyPairing theirjid) $ do
		changeBuddyPairing theirjid False
		selfuuid <- liftAnnex getUUID
		sendNetMessage $
			PairingNotification PairDone (formatJID theirjid) selfuuid
		finishXMPPPairing theirjid theiruuid

pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
	changeBuddyPairing theirjid False

isBuddyPairing :: JID -> Assistant Bool
isBuddyPairing jid = maybe False buddyPairing <$>
	getBuddy (genBuddyKey jid) <<~ buddyList

changeBuddyPairing :: JID -> Bool -> Assistant ()
changeBuddyPairing jid ispairing =
	updateBuddyList (M.adjust set key) <<~ buddyList
  where
	key = genBuddyKey jid
	set b = b { buddyPairing = ispairing }

repo_name: kakafarm/git

license: unknown


code:
{- git-annex XMPP pusher threads
 -
 - This is a pair of threads. One handles git send-pack,
 - and the other git receive-pack. Each thread can be running at most
 - one such operation at a time.
 -
 - Why not use a single thread? Consider two clients A and B.
 - If both decide to run a receive-pack at the same time to the other,
 - they would deadlock with only one thread. For larger numbers of
 - clients, the two threads are also sufficient.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Threads.XMPPPusher where

import Assistant.Common
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.WebApp (UrlRenderer)
import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
import Assistant.XMPP.Git

import Control.Exception as E

xmppSendPackThread :: UrlRenderer -> NamedThread
xmppSendPackThread = pusherThread "XMPPSendPack" SendPack

xmppReceivePackThread :: UrlRenderer -> NamedThread
xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack

pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
  where
  	go lastpushedto = do
		msg <- waitPushInitiation side $ selectNextPush lastpushedto
		debug ["started running push", logNetMessage msg]

		runpush <- asIO $ runPush checker msg
		r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID)))
		let successful = case r of
			Right (Just _) -> True
			_ -> False

		{- Empty the inbox, because stuff may have
		 - been left in it if the push failed. -}
		let justpushedto = getclient msg
		maybe noop (`emptyInbox` side) justpushedto

		debug ["finished running push", logNetMessage msg, show successful]
		go $ if successful then justpushedto else lastpushedto

	checker = checkCloudRepos urlrenderer

	getclient (Pushing cid _) = Just cid
	getclient _ = Nothing

{- Select the next push to run from the queue.
 - The queue cannot be empty!
 -
 - We prefer to select the most recently added push, because its requestor
 - is more likely to still be connected.
 -
 - When passed the ID of a client we just pushed to, we prefer to not
 - immediately push again to that same client. This avoids one client
 - drowing out others. So pushes from the client we just pushed to are
 - relocated to the beginning of the list, to be processed later.
 -}
selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage])
selectNextPush _ (m:[]) = (m, []) -- common case
selectNextPush _ [] = error "selectNextPush: empty list"
selectNextPush lastpushedto l = go [] l
  where
	go (r:ejected) [] = (r, ejected)
	go rejected (m:ms) = case m of
		(Pushing clientid _)
			| Just clientid /= lastpushedto -> (m, rejected ++ ms)
		_ -> go (m:rejected) ms
  	go [] [] = undefined


code:
{- git-annex assistant pending transfer queue
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns #-}

module Assistant.TransferQueue (
	TransferQueue,
	Schedule(..),
	newTransferQueue,
	getTransferQueue,
	queueTransfers,
	queueTransfersMatching,
	queueDeferredDownloads,
	queueTransfer,
	queueTransferAt,
	queueTransferWhenSmall,
	getNextTransfer,
	getMatchingTransfers,
	dequeueTransfers,
) where

import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Types.TransferQueue
import Logs.Transfer
import Types.Remote
import qualified Remote
import qualified Types.Remote as Remote
import Annex.Wanted
import Utility.TList

import Control.Concurrent.STM
import qualified Data.Map as M
import qualified Data.Set as S

type Reason = String

{- Reads the queue's content without blocking or changing it. -}
getTransferQueue :: Assistant [(Transfer, TransferInfo)]
getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue

stubInfo :: AssociatedFile -> Remote -> TransferInfo
stubInfo f r = stubTransferInfo
	{ transferRemote = Just r
	, associatedFile = f
	}

{- Adds transfers to queue for some of the known remotes.
 - Honors preferred content settings, only transferring wanted files. -}
queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
queueTransfers = queueTransfersMatching (const True)

{- Adds transfers to queue for some of the known remotes, that match a
 - condition. Honors preferred content settings. -}
queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
queueTransfersMatching matching reason schedule k f direction
	| direction == Download = ifM (liftAnnex $ wantGet True (Just k) f)
		( go
		, return False
		)
	| otherwise = go
  where
	go = do

		rs <- liftAnnex . selectremotes
			=<< syncDataRemotes <$> getDaemonStatus
		let matchingrs = filter (matching . Remote.uuid) rs
		if null matchingrs
			then do
				defer
				return False
			else do
				forM_ matchingrs $ \r ->
					enqueue reason schedule (gentransfer r) (stubInfo f r)
				return True
	selectremotes rs
		{- Queue downloads from all remotes that
		 - have the key. The list of remotes is ordered with
		 - cheapest first. More expensive ones will only be tried
		 - if downloading from a cheap one fails. -}
		| direction == Download = do
			s <- locs
			return $ filter (inset s) rs
		{- Upload to all remotes that want the content and don't
		 - already have it. -}
		| otherwise = do
			s <- locs
			filterM (wantSend True (Just k) f . Remote.uuid) $
				filter (\r -> not (inset s r || Remote.readonly r)) rs
	  where
	  	locs = S.fromList <$> Remote.keyLocations k
		inset s r = S.member (Remote.uuid r) s
	gentransfer r = Transfer
		{ transferDirection = direction
		, transferKey = k
		, transferUUID = Remote.uuid r
		}
	defer
		{- Defer this download, as no known remote has the key. -}
		| direction == Download = do
			q <- getAssistant transferQueue
			void $ liftIO $ atomically $
				consTList (deferreddownloads q) (k, f)
		| otherwise = noop

{- Queues any deferred downloads that can now be accomplished, leaving
 - any others in the list to try again later. -}
queueDeferredDownloads :: Reason -> Schedule -> Assistant ()
queueDeferredDownloads reason schedule = do
	q <- getAssistant transferQueue
	l <- liftIO $ atomically $ readTList (deferreddownloads q)
	rs <- syncDataRemotes <$> getDaemonStatus
	left <- filterM (queue rs) l
	unless (null left) $
		liftIO $ atomically $ appendTList (deferreddownloads q) left
  where
	queue rs (k, f) = do
		uuids <- liftAnnex $ Remote.keyLocations k
		let sources = filter (\r -> uuid r `elem` uuids) rs
		unless (null sources) $
			forM_ sources $ \r ->
				enqueue reason schedule
					(gentransfer r) (stubInfo f r)
		return $ null sources
	  where
		gentransfer r = Transfer
			{ transferDirection = Download
			, transferKey = k
			, transferUUID = Remote.uuid r
			}

enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
enqueue reason schedule t info
	| schedule == Next = go consTList
	| otherwise = go snocTList
  where
	go modlist = whenM (add modlist) $ do
		debug [ "queued", describeTransfer t info, ": " ++ reason ]
		notifyTransfer
	add modlist = do
		q <- getAssistant transferQueue
		dstatus <- getAssistant daemonStatusHandle
		liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
			( return False
			, do
				l <- readTList (queuelist q)
				if (t `notElem` map fst l)
					then do
						void $ modifyTVar' (queuesize q) succ
						void $ modlist (queuelist q) (t, info)
						return True
					else return False
			)

{- Adds a transfer to the queue. -}
queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransfer reason schedule f t remote =
	enqueue reason schedule t (stubInfo f remote)

{- Blocks until the queue is no larger than a given size, and then adds a
 - transfer to the queue. -}
queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransferAt wantsz reason schedule f t remote = do
	q <- getAssistant transferQueue
	liftIO $ atomically $ do
		sz <- readTVar (queuesize q)
		unless (sz <= wantsz) $
			retry -- blocks until queuesize changes
	enqueue reason schedule t (stubInfo f remote)

queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransferWhenSmall reason = queueTransferAt 10 reason Later

{- Blocks until a pending transfer is available in the queue,
 - and removes it.
 -
 - Checks that it's acceptable, before adding it to the
 - currentTransfers map. If it's not acceptable, it's discarded.
 -
 - This is done in a single STM transaction, so there is no window
 - where an observer sees an inconsistent status. -}
getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo))
getNextTransfer acceptable = do
	q <- getAssistant transferQueue
	dstatus <- getAssistant daemonStatusHandle
	liftIO $ atomically $ do
		sz <- readTVar (queuesize q)
		if sz < 1
			then retry -- blocks until queuesize changes
			else do
				(r@(t,info):rest) <- readTList (queuelist q)
				void $ modifyTVar' (queuesize q) pred
				setTList (queuelist q) rest
				if acceptable info
					then do
						adjustTransfersSTM dstatus $
							M.insertWith' const t info
						return $ Just r
					else return Nothing

{- Moves transfers matching a condition from the queue, to the
 - currentTransfers map. -}
getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
getMatchingTransfers c = do
	q <- getAssistant transferQueue
	dstatus <- getAssistant daemonStatusHandle
	liftIO $ atomically $ do
		ts <- dequeueTransfersSTM q c
		unless (null ts) $
			adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts
		return ts

{- Removes transfers matching a condition from the queue, and returns the
 - removed transfers. -}
dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
dequeueTransfers c = do
	q <- getAssistant transferQueue
	removed <- liftIO $ atomically $ dequeueTransfersSTM q c
	unless (null removed) $
		notifyTransfer
	return removed

dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]
dequeueTransfersSTM q c = do
	!(removed, ts) <- partition (c . fst) <$> readTList (queuelist q)
	let !len = length ts
	void $ writeTVar (queuesize q) len
	setTList (queuelist q) ts
	return removed


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

{-# LANGUAGE CPP #-}

module Assistant.TransferSlots where

import Assistant.Common
import Utility.ThreadScheduler
import Assistant.Types.TransferSlots
import Assistant.DaemonStatus
import Assistant.TransferrerPool
import Assistant.Types.TransferrerPool
import Assistant.Types.TransferQueue
import Assistant.TransferQueue
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.Commits
import Assistant.Drop
import Logs.Transfer
import Logs.Location
import qualified Git
import qualified Remote
import qualified Types.Remote as Remote
import Annex.Content
import Annex.Wanted
import Config.Files
import Utility.Batch

import qualified Data.Map as M
import qualified Control.Exception as E
import Control.Concurrent
import qualified Control.Concurrent.MSemN as MSemN
#ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessGroupIDOf)
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
#else
import Utility.WinProcess
#endif

type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))

{- Waits until a transfer slot becomes available, then runs a
 - TransferGenerator, and then runs the transfer action in its own thread.
 -}
inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
inTransferSlot program batchmaker gen = do
	flip MSemN.wait 1 <<~ transferSlots
	runTransferThread program batchmaker =<< gen

{- Runs a TransferGenerator, and its transfer action,
 - without waiting for a slot to become available. -}
inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
inImmediateTransferSlot program batchmaker gen = do
	flip MSemN.signal (-1) <<~ transferSlots
	runTransferThread program batchmaker =<< gen

{- Runs a transfer action, in an already allocated transfer slot.
 - Once it finishes, frees the transfer slot.
 -
 - Note that the action is subject to being killed when the transfer
 - is canceled or paused.
 -
 - A PauseTransfer exception is handled by letting the action be killed,
 - then pausing the thread until a ResumeTransfer exception is raised,
 - then rerunning the action.
 -}
runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots
runTransferThread program batchmaker (Just (t, info, a)) = do
	d <- getAssistant id
	aio <- asIO1 a
	tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio
	updateTransferInfo t $ info { transferTid = Just tid }

runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO ()
runTransferThread' program batchmaker d run = go
  where
	go = catchPauseResume $
		withTransferrer program batchmaker (transferrerPool d)
			run
	pause = catchPauseResume $
		runEvery (Seconds 86400) noop
	{- Note: This must use E.try, rather than E.catch.
	 - When E.catch is used, and has called go in its exception
	 - handler, Control.Concurrent.throwTo will block sometimes
	 - when signaling. Using E.try avoids the problem. -}
	catchPauseResume a' = do
		r <- E.try a' :: IO (Either E.SomeException ())
		case r of
			Left e -> case E.fromException e of
				Just PauseTransfer -> pause
				Just ResumeTransfer -> go
				_ -> done
			_ -> done
	done = runAssistant d $
		flip MSemN.signal 1 <<~ transferSlots

{- By the time this is called, the daemonstatus's currentTransfers map should
 - already have been updated to include the transfer. -}
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
genTransfer t info = case transferRemote info of
	Just remote
		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
			-- optimisation for removable drives not plugged in
			liftAnnex $ recordFailedTransfer t info
			void $ removeTransfer t
			return Nothing
		| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
			( do
				debug [ "Transferring:" , describeTransfer t info ]
				notifyTransfer
				return $ Just (t, info, go remote)
			, do
				debug [ "Skipping unnecessary transfer:",
					describeTransfer t info ]
				void $ removeTransfer t
				finishedTransfer t (Just info)
				return Nothing
			)
	_ -> return Nothing
  where
	direction = transferDirection t
	isdownload = direction == Download

	{- Alerts are only shown for successful transfers.
	 - Transfers can temporarily fail for many reasons,
	 - so there's no point in bothering the user about
	 - those. The assistant should recover.
	 -
	 - After a successful upload, handle dropping it from
	 - here, if desired. In this case, the remote it was
	 - uploaded to is known to have it.
	 -
	 - Also, after a successful transfer, the location
	 - log has changed. Indicate that a commit has been
	 - made, in order to queue a push of the git-annex
	 - branch out to remotes that did not participate
	 - in the transfer.
	 -
	 - If the process failed, it could have crashed,
	 - so remove the transfer from the list of current
	 - transfers, just in case it didn't stop
	 - in a way that lets the TransferWatcher do its
	 - usual cleanup. However, first check if something else is
	 - running the transfer, to avoid removing active transfers.
	 -}
	go remote transferrer = ifM (liftIO $ performTransfer transferrer t info)
		( do
			maybe noop
				(void . addAlert . makeAlertFiller True
					. transferFileAlert direction True)
				(associatedFile info)
			unless isdownload $
				handleDrops
					("object uploaded to " ++ show remote)
					True (transferKey t)
					(associatedFile info)
					(Just remote)
			void recordCommit
		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
			void $ removeTransfer t
		)

{- Called right before a transfer begins, this is a last chance to avoid
 - unnecessary transfers.
 -
 - For downloads, we obviously don't need to download if the already
 - have the object.
 -
 - Smilarly, for uploads, check if the remote is known to already have
 - the object.
 -
 - Also, uploads get queued to all remotes, in order of cost.
 - This may mean, for example, that an object is uploaded over the LAN
 - to a locally paired client, and once that upload is done, a more
 - expensive transfer remote no longer wants the object. (Since
 - all the clients have it already.) So do one last check if this is still
 - preferred content.
 -
 - We'll also do one last preferred content check for downloads. An
 - example of a case where this could be needed is if a download is queued
 - for a file that gets moved out of an archive directory -- but before
 - that download can happen, the file is put back in the archive.
 -}
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
shouldTransfer t info
	| transferDirection t == Download =
		(not <$> inAnnex key) <&&> wantGet True (Just key) file
	| transferDirection t == Upload = case transferRemote info of
		Nothing -> return False
		Just r -> notinremote r
			<&&> wantSend True (Just key) file (Remote.uuid r)
	| otherwise = return False
  where
	key = transferKey t
	file = associatedFile info

	{- Trust the location log to check if the remote already has
	 - the key. This avoids a roundtrip to the remote. -}
	notinremote r = notElem (Remote.uuid r) <$> loggedLocations key

{- Queue uploads of files downloaded to us, spreading them
 - out to other reachable remotes.
 -
 - Downloading a file may have caused a remote to not want it;
 - so check for drops from remotes.
 -
 - Uploading a file may cause the local repo, or some other remote to not
 - want it; handle that too.
 -}
finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
finishedTransfer t (Just info)
	| transferDirection t == Download =
		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
			dodrops False
			void $ queueTransfersMatching (/= transferUUID t)
				"newly received object"
				Later (transferKey t) (associatedFile info) Upload
	| otherwise = dodrops True
  where
	dodrops fromhere = handleDrops
		("drop wanted after " ++ describeTransfer t info)
		fromhere (transferKey t) (associatedFile info) Nothing
finishedTransfer _ _ = noop

{- Pause a running transfer. -}
pauseTransfer :: Transfer -> Assistant ()
pauseTransfer = cancelTransfer True

{- Cancel a running transfer. -}
cancelTransfer :: Bool -> Transfer -> Assistant ()
cancelTransfer pause t = do
	m <- getCurrentTransfers
	unless pause $
		{- remove queued transfer -}
		void $ dequeueTransfers $ equivilantTransfer t
	{- stop running transfer -}
	maybe noop stop (M.lookup t m)
  where
	stop info = do
		{- When there's a thread associated with the
		 - transfer, it's signaled first, to avoid it
		 - displaying any alert about the transfer having
		 - failed when the transfer process is killed. -}
		liftIO $ maybe noop signalthread $ transferTid info
		liftIO $ maybe noop killproc $ transferPid info
		if pause
			then void $ alterTransferInfo t $
				\i -> i { transferPaused = True }
			else void $ removeTransfer t
	signalthread tid
		| pause = throwTo tid PauseTransfer
		| otherwise = killThread tid
	killproc pid = void $ tryIO $ do
#ifndef mingw32_HOST_OS
		{- In order to stop helper processes like rsync,
		 - kill the whole process group of the process
		 - running the transfer. -}
		g <- getProcessGroupIDOf pid
		let signal sig = void $ tryIO $ signalProcessGroup sig g
		signal sigTERM
		threadDelay 50000 -- 0.05 second grace period
		signal sigKILL
#else
		terminatePID pid
#endif

{- Start or resume a transfer. -}
startTransfer :: Transfer -> Assistant ()
startTransfer t = do
	m <- getCurrentTransfers
	maybe startqueued go (M.lookup t m)
  where
	go info = maybe (start info) resume $ transferTid info
	startqueued = do
		is <- map snd <$> getMatchingTransfers (== t)
		maybe noop start $ headMaybe is
	resume tid = do
		alterTransferInfo t $ \i -> i { transferPaused = False }
		liftIO $ throwTo tid ResumeTransfer
	start info = do
		program <- liftIO readProgramFile
		batchmaker <- liftIO getBatchCommandMaker
		inImmediateTransferSlot program batchmaker $
			genTransfer t info

getCurrentTransfers :: Assistant TransferMap
getCurrentTransfers = currentTransfers <$> getDaemonStatus


code:
{- A pool of "git-annex transferkeys" processes
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.TransferrerPool where

import Assistant.Common
import Assistant.Types.TransferrerPool
import Logs.Transfer
import Utility.Batch

import qualified Command.TransferKeys as T

import Control.Concurrent.STM hiding (check)
import Control.Exception (throw)
import Control.Concurrent

{- Runs an action with a Transferrer from the pool.
 -
 - Only one Transferrer is left running in the pool at a time.
 - So if this needed to start a new Transferrer, it's stopped when done.
 -}
withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a
withTransferrer program batchmaker pool a = do
	(mi, leftinpool) <- atomically (popTransferrerPool pool)
	i@(TransferrerPoolItem (Just t) check) <- case mi of
		Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker
		Just i -> checkTransferrerPoolItem program batchmaker i
	v <- tryNonAsync $ a t
	if leftinpool == 0
		then atomically $ pushTransferrerPool pool i
		else do
			void $ forkIO $ stopTransferrer t
			atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check
	either throw return v

{- Check if a Transferrer from the pool is still ok to be used.
 - If not, stop it and start a new one. -}
checkTransferrerPoolItem :: FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO TransferrerPoolItem
checkTransferrerPoolItem program batchmaker i = case i of
	TransferrerPoolItem (Just t) check -> ifM check
		( return i
		, do
			stopTransferrer t
			new check
		)
	TransferrerPoolItem Nothing check -> new check
  where
	new check = do
		t <- mkTransferrer program batchmaker
		return $ TransferrerPoolItem (Just t) check

{- Requests that a Transferrer perform a Transfer, and waits for it to
 - finish. -}
performTransfer :: Transferrer -> Transfer -> TransferInfo -> IO Bool
performTransfer transferrer t info = catchBoolIO $ do
	T.sendRequest t info (transferrerWrite transferrer)
	T.readResponse (transferrerRead transferrer)

{- Starts a new git-annex transferkeys process, setting up handles
 - that will be used to communicate with it. -}
mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
mkTransferrer program batchmaker = do
	{- It runs as a batch job. -}
	let (program', params') = batchmaker (program, [Param "transferkeys"])
	{- It's put into its own group so that the whole group can be
	 - killed to stop a transfer. -}
	(Just writeh, Just readh, _, pid) <- createProcess
		(proc program' $ toCommand params')
		{ create_group = True
		, std_in = CreatePipe
		, std_out = CreatePipe
		}
	fileEncoding readh
	fileEncoding writeh
	return $ Transferrer
		{ transferrerRead = readh
		, transferrerWrite = writeh
		, transferrerHandle = pid
		}

{- Checks if a Transferrer is still running. If not, makes a new one. -}
checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer
checkTransferrer program batchmaker t =
	maybe (return t) (const $ mkTransferrer program batchmaker)
		=<< getProcessExitCode (transferrerHandle t)

{- Closing the fds will stop the transferrer. -}
stopTransferrer :: Transferrer -> IO ()
stopTransferrer t = do
	hClose $ transferrerRead t
	hClose $ transferrerWrite t
	void $ waitForProcess $ transferrerHandle t


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

module Assistant.Types.Alert where

import Utility.Tense

import Data.Text (Text)
import qualified Data.Map as M

{- Different classes of alerts are displayed differently. -}
data AlertClass = Success | Message | Activity | Warning | Error
	deriving (Eq, Ord)

data AlertPriority = Filler | Low | Medium | High | Pinned
	deriving (Eq, Ord)

{- An alert can have an name, which is used to combine it with other similar
 - alerts. -}
data AlertName
	= FileAlert TenseChunk
	| SanityCheckFixAlert
	| WarningAlert String
	| PairAlert String
	| ConnectionNeededAlert
	| RemoteRemovalAlert String
	| CloudRepoNeededAlert
	| SyncAlert
	| NotFsckedAlert
	| UpgradeAlert
	| UnusedFilesAlert
	deriving (Eq)

{- The first alert is the new alert, the second is an old alert.
 - Should return a modified version of the old alert. -}
type AlertCombiner = Alert -> Alert -> Maybe Alert

data Alert = Alert
	{ alertClass :: AlertClass
	, alertHeader :: Maybe TenseText
	, alertMessageRender :: Alert -> TenseText
	, alertData :: [TenseChunk]
	, alertCounter :: Int
	, alertBlockDisplay :: Bool
	, alertClosable :: Bool
	, alertPriority :: AlertPriority
	, alertIcon :: Maybe AlertIcon
	, alertCombiner :: Maybe AlertCombiner
	, alertName :: Maybe AlertName
	, alertButtons :: [AlertButton]
	}

data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | ConnectionIcon

type AlertMap = M.Map AlertId Alert

{- Higher AlertId indicates a more recent alert. -}
newtype AlertId = AlertId Integer
	deriving (Read, Show, Eq, Ord)

firstAlertId :: AlertId
firstAlertId = AlertId 0

nextAlertId :: AlertId -> AlertId
nextAlertId (AlertId i) = AlertId $ succ i

{- When clicked, a button always redirects to a URL
 - It may also run an IO action in the background, which is useful
 - to make the button close or otherwise change the alert. -}
data AlertButton = AlertButton
	{ buttonLabel :: Text
	, buttonUrl :: Text
	, buttonAction :: Maybe (AlertId -> IO ())
	, buttonPrimary :: Bool
	}


code:
{- git-annex assistant git-annex branch change tracking
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Types.BranchChange where

import Control.Concurrent.MSampleVar
import Common.Annex

newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())

newBranchChangeHandle :: IO BranchChangeHandle
newBranchChangeHandle = BranchChangeHandle <$> newEmptySV

fromBranchChangeHandle :: BranchChangeHandle -> MSampleVar ()
fromBranchChangeHandle (BranchChangeHandle v) = v


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

{-# LANGUAGE CPP #-}

module Assistant.Types.Buddies where

import Common.Annex

import qualified Data.Map as M
import Control.Concurrent.STM
import Utility.NotificationBroadcaster
import Data.Text as T

{- For simplicity, dummy types are defined even when XMPP is disabled. -}
#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Data.Set as S
import Data.Ord

newtype Client = Client JID
	deriving (Eq, Show)

instance Ord Client where
	compare = comparing show

data Buddy = Buddy
	{ buddyPresent :: S.Set Client
	, buddyAway :: S.Set Client
	, buddyAssistants :: S.Set Client
	, buddyPairing :: Bool
	}
#else
data Buddy = Buddy
#endif
	deriving (Eq, Show)

data BuddyKey = BuddyKey T.Text
	deriving (Eq, Ord, Show, Read)

data PairKey = PairKey UUID T.Text
	deriving (Eq, Ord, Show, Read)

type Buddies = M.Map BuddyKey Buddy

{- A list of buddies, and a way to notify when it changes. -}
type BuddyList = (TMVar Buddies, NotificationBroadcaster)

noBuddies :: Buddies
noBuddies = M.empty

newBuddyList :: IO BuddyList
newBuddyList = (,)
	<$> atomically (newTMVar noBuddies)
	<*> newNotificationBroadcaster

getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)

getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)

getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
getBuddyBroadcaster (_, h) = h

{- Applies a function to modify the buddy list, and if it's changed,
 - sends notifications to any listeners. -}
updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
updateBuddyList a (v, caster) = do
	changed <- atomically $ do
		buds <- takeTMVar v
		let buds' = a buds
		putTMVar v buds'
		return $ buds /= buds'
	when changed $
		sendNotification caster


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

module Assistant.Types.Changes where

import Types.KeySource
import Types.Key
import Utility.TList

import Control.Concurrent.STM
import Data.Time.Clock

{- An un-ordered pool of Changes that have been noticed and should be
 - staged and committed. Changes will typically be in order, but ordering
 - may be lost. In any case, order should not matter, as any given Change
 - may later be reverted by a later Change (ie, a file is added and then
 - deleted). Code that processes the changes needs to deal with such
 - scenarios.
 -}
type ChangePool = TList Change

newChangePool :: IO ChangePool
newChangePool = atomically newTList

data Change
	= Change
		{ changeTime :: UTCTime
		, _changeFile :: FilePath
		, changeInfo :: ChangeInfo
		}
	| PendingAddChange
		{ changeTime ::UTCTime
		, _changeFile :: FilePath
		}
	| InProcessAddChange
		{ changeTime ::UTCTime
		, keySource :: KeySource
		}
	deriving (Show)

data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange
	deriving (Show, Eq, Ord)

changeInfoKey :: ChangeInfo -> Maybe Key
changeInfoKey (AddKeyChange k) = Just k
changeInfoKey (LinkChange (Just k)) = Just k
changeInfoKey _ = Nothing

changeFile :: Change -> FilePath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
changeFile (InProcessAddChange _ ks) = keyFilename ks

isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
isPendingAddChange _ = False

isInProcessAddChange :: Change -> Bool
isInProcessAddChange (InProcessAddChange {}) = True
isInProcessAddChange _ = False

retryChange :: Change -> Change
retryChange (InProcessAddChange time ks) =
	PendingAddChange time (keyFilename ks)
retryChange c = c

finishedChange :: Change -> Key -> Change
finishedChange c@(InProcessAddChange { keySource = ks }) k = Change
	{ changeTime = changeTime c
	, _changeFile = keyFilename ks
	, changeInfo = AddKeyChange k
	}
finishedChange c _ = c


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

module Assistant.Types.Commits where

import Utility.TList

import Control.Concurrent.STM

type CommitChan = TList Commit

data Commit = Commit

newCommitChan :: IO CommitChan
newCommitChan = atomically newTList


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

module Assistant.Types.CredPairCache where

import Types.Creds

import Control.Concurrent
import qualified Data.Map as M

type CredPairCache = MVar (M.Map Login Password)

newCredPairCache :: IO CredPairCache
newCredPairCache = newMVar M.empty


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

module Assistant.Types.DaemonStatus where

import Common.Annex
import Assistant.Pairing
import Utility.NotificationBroadcaster
import Logs.Transfer
import Assistant.Types.ThreadName
import Assistant.Types.NetMessager
import Assistant.Types.Alert
import Utility.Url

import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Concurrent.Async
import Data.Time.Clock.POSIX
import qualified Data.Map as M
import qualified Data.Set as S

data DaemonStatus = DaemonStatus
	-- All the named threads that comprise the daemon,
	-- and actions to run to restart them.
	{ startedThreads :: M.Map ThreadName (Async (), IO ())
	-- False when the daemon is performing its startup scan
	, scanComplete :: Bool
	-- True when all files should be restaged.
	, forceRestage :: Bool
	-- Time when a previous process of the daemon was running ok
	, lastRunning :: Maybe POSIXTime
	-- True when the daily sanity checker is running
	, sanityCheckRunning :: Bool
	-- Last time the daily sanity checker ran
	, lastSanityCheck :: Maybe POSIXTime
	-- True when a scan for file transfers is running
	, transferScanRunning :: Bool
	-- Currently running file content transfers
	, currentTransfers :: TransferMap
	-- Messages to display to the user.
	, alertMap :: AlertMap
	, lastAlertId :: AlertId
	-- Ordered list of all remotes that can be synced with
	, syncRemotes :: [Remote]
	-- Ordered list of remotes to sync git with
	, syncGitRemotes :: [Remote]
	-- Ordered list of remotes to sync data with
	, syncDataRemotes :: [Remote]
	-- Are we syncing to any cloud remotes?
	, syncingToCloudRemote :: Bool
	-- Set of uuids of remotes that are currently connected.
	, currentlyConnectedRemotes :: S.Set UUID
	-- List of uuids of remotes that we may have gotten out of sync with.
	, desynced :: S.Set UUID
	-- Pairing request that is in progress.
	, pairingInProgress :: Maybe PairingInProgress
	-- Broadcasts notifications about all changes to the DaemonStatus.
	, changeNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when queued or current transfers change.
	, transferNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when there's a change to the alerts.
	, alertNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when the syncRemotes change.
	, syncRemotesNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when the scheduleLog changes.
	, scheduleLogNotifier :: NotificationBroadcaster
	-- Broadcasts a notification once the startup sanity check has run.
	, startupSanityCheckNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when the network is connected.
	, networkConnectedNotifier :: NotificationBroadcaster
	-- Broadcasts notifications when a global redirect is needed.
	, globalRedirNotifier :: NotificationBroadcaster
	, globalRedirUrl :: Maybe URLString
	-- Actions to run after a Key is transferred.
	, transferHook :: M.Map Key (Transfer -> IO ())
	-- When the XMPP client is connected, this will contain the XMPP
	-- address.
	, xmppClientID :: Maybe ClientID
	-- MVars to signal when a remote gets connected.
	, connectRemoteNotifiers :: M.Map UUID [MVar ()]
	}

type TransferMap = M.Map Transfer TransferInfo

{- This TMVar is never left empty, so accessing it will never block. -}
type DaemonStatusHandle = TMVar DaemonStatus

newDaemonStatus :: IO DaemonStatus
newDaemonStatus = DaemonStatus
	<$> pure M.empty
	<*> pure False
	<*> pure False
	<*> pure Nothing
	<*> pure False
	<*> pure Nothing
	<*> pure False
	<*> pure M.empty
	<*> pure M.empty
	<*> pure firstAlertId
	<*> pure []
	<*> pure []
	<*> pure []
	<*> pure False
	<*> pure S.empty
	<*> pure S.empty
	<*> pure Nothing
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> newNotificationBroadcaster
	<*> pure Nothing
	<*> pure M.empty
	<*> pure Nothing
	<*> pure M.empty


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

module Assistant.Types.NamedThread where

import Assistant.Monad
import Assistant.Types.ThreadName

{- Information about a named thread that can be run. -}
data NamedThread = NamedThread Bool ThreadName (Assistant ())

namedThread :: String -> Assistant () -> NamedThread
namedThread = NamedThread True . ThreadName

{- A named thread that can start running before the startup sanity check. -}
namedThreadUnchecked :: String -> Assistant () -> NamedThread
namedThreadUnchecked = NamedThread False . ThreadName


code:
{- git-annex assistant out of band network messager types
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Types.NetMessager where

import Common.Annex
import Assistant.Pairing
import Git.Types

import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.DList as D
import Control.Concurrent.STM
import Control.Concurrent.MSampleVar
import Data.ByteString (ByteString)
import Data.Text (Text)

{- Messages that can be sent out of band by a network messager. -}
data NetMessage
	-- indicate that pushes have been made to the repos with these uuids
	= NotifyPush [UUID]
	-- requests other clients to inform us of their presence
	| QueryPresence
	-- notification about a stage in the pairing process,
	-- involving a client, and a UUID.
	| PairingNotification PairStage ClientID UUID
	-- used for git push over the network messager
	| Pushing ClientID PushStage
	deriving (Eq, Ord, Show)

{- Something used to identify the client, or clients to send the message to. -}
type ClientID = Text

data PushStage
	-- indicates that we have data to push over the out of band network
	= CanPush UUID [Sha]
	-- request that a git push be sent over the out of band network
	| PushRequest UUID
	-- indicates that a push is starting
	| StartingPush UUID
	-- a chunk of output of git receive-pack
	| ReceivePackOutput SequenceNum ByteString
	-- a chuck of output of git send-pack
	| SendPackOutput SequenceNum ByteString
	-- sent when git receive-pack exits, with its exit code
	| ReceivePackDone ExitCode
	deriving (Eq, Ord, Show)

{- A sequence number. Incremented by one per packet in a sequence,
 - starting with 1 for the first packet. 0 means sequence numbers are
 - not being used. -}
type SequenceNum = Int

{- NetMessages that are important (and small), and should be stored to be
 - resent when new clients are seen. -}
isImportantNetMessage :: NetMessage -> Maybe ClientID
isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
isImportantNetMessage (Pushing c (PushRequest _)) = Just c
isImportantNetMessage _ = Nothing

{- Checks if two important NetMessages are equivilant.
 - That is to say, assuming they were sent to the same client,
 - would it do the same thing for one as for the other? -}
equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool
equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True
equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True
equivilantImportantNetMessages _ _ = False

readdressNetMessage :: NetMessage -> ClientID -> NetMessage
readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid
readdressNetMessage (Pushing _ stage) c = Pushing c stage
readdressNetMessage m _ = m

{- Convert a NetMessage to something that can be logged. -}
logNetMessage :: NetMessage -> String
logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
	case stage of
		ReceivePackOutput n _ -> ReceivePackOutput n elided
		SendPackOutput n _ -> SendPackOutput n elided
		s -> s
  where
  	elided = T.encodeUtf8 $ T.pack "<elided>"
logNetMessage (PairingNotification stage c uuid) =
	show $ PairingNotification stage (logClientID c) uuid
logNetMessage m = show m

logClientID :: ClientID -> ClientID
logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]

{- Things that initiate either side of a push, but do not actually send data. -}
isPushInitiation :: PushStage -> Bool
isPushInitiation (PushRequest _) = True
isPushInitiation (StartingPush _) = True
isPushInitiation _ = False

isPushNotice :: PushStage -> Bool
isPushNotice (CanPush _ _) = True
isPushNotice _ = False

data PushSide = SendPack | ReceivePack
	deriving (Eq, Ord, Show)

pushDestinationSide :: PushStage -> PushSide
pushDestinationSide (CanPush _ _) = ReceivePack
pushDestinationSide (PushRequest _) = SendPack
pushDestinationSide (StartingPush _) = ReceivePack
pushDestinationSide (ReceivePackOutput _ _) = SendPack
pushDestinationSide (SendPackOutput _ _) = ReceivePack
pushDestinationSide (ReceivePackDone _) = SendPack

type SideMap a = PushSide -> a

mkSideMap :: STM a -> IO (SideMap a)
mkSideMap gen = do
	(sp, rp) <- atomically $ (,) <$> gen <*> gen
	return $ lookupside sp rp
  where
	lookupside sp _ SendPack = sp
	lookupside _ rp ReceivePack = rp

getSide :: PushSide -> SideMap a -> a
getSide side m = m side

type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))

data NetMessager = NetMessager
	-- outgoing messages
	{ netMessages :: TChan NetMessage
	-- important messages for each client
	, importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
	-- important messages that are believed to have been sent to a client
	, sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
	-- write to this to restart the net messager
	, netMessagerRestart :: MSampleVar ()
	-- queue of incoming messages that request the initiation of pushes
	, netMessagerPushInitiations :: SideMap (TMVar [NetMessage])
	-- incoming messages containing data for a running
	-- (or not yet started) push
	, netMessagerInboxes :: SideMap Inboxes
	}

newNetMessager :: IO NetMessager
newNetMessager = NetMessager
	<$> atomically newTChan
	<*> atomically (newTMVar M.empty)
	<*> atomically (newTMVar M.empty)
	<*> newEmptySV
	<*> mkSideMap newEmptyTMVar
	<*> mkSideMap (newTVar M.empty)


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

module Assistant.Types.Pushes where

import Common.Annex

import Control.Concurrent.STM
import Data.Time.Clock
import qualified Data.Map as M

{- Track the most recent push failure for each remote. -}
type PushMap = M.Map Remote UTCTime
type FailedPushMap = TMVar PushMap

{- The TMVar starts empty, and is left empty when there are no
 - failed pushes. This way we can block until there are some failed pushes.
 -}
newFailedPushMap :: IO FailedPushMap
newFailedPushMap = atomically newEmptyTMVar


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

module Assistant.Types.RemoteControl where

import qualified RemoteDaemon.Types as RemoteDaemon
import Control.Concurrent

type RemoteControl = Chan RemoteDaemon.Consumed

newRemoteControl :: IO RemoteControl
newRemoteControl = newChan


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

module Assistant.Types.RepoProblem where

import Types
import Utility.TList

import Control.Concurrent.STM
import Data.Function

data RepoProblem = RepoProblem
	{ problemUUID :: UUID
	, afterFix :: IO ()
	}

{- The afterFix actions are assumed to all be equivilant. -}
sameRepoProblem :: RepoProblem -> RepoProblem -> Bool
sameRepoProblem = (==) `on` problemUUID

type RepoProblemChan = TList RepoProblem

newRepoProblemChan :: IO RepoProblemChan
newRepoProblemChan = atomically newTList


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

module Assistant.Types.ScanRemotes where

import Common.Annex

import Control.Concurrent.STM
import qualified Data.Map as M

data ScanInfo = ScanInfo
	{ scanPriority :: Float
	, fullScan :: Bool
	}

type ScanRemoteMap = TMVar (M.Map Remote ScanInfo)

{- The TMVar starts empty, and is left empty when there are no remotes
 - to scan. -}
newScanRemoteMap :: IO ScanRemoteMap
newScanRemoteMap = atomically newEmptyTMVar


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

module Assistant.Types.ThreadName where

newtype ThreadName = ThreadName String
	deriving (Eq, Read, Show, Ord)

fromThreadName :: ThreadName -> String
fromThreadName (ThreadName n) = n


code:
{- making the Annex monad available across threads
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Types.ThreadedMonad where

import Common.Annex
import qualified Annex

import Control.Concurrent
import Data.Tuple

{- The Annex state is stored in a MVar, so that threaded actions can access
 - it. -}
type ThreadState = MVar Annex.AnnexState

{- Stores the Annex state in a MVar.
 -
 - Once the action is finished, retrieves the state from the MVar.
 -}
withThreadState :: (ThreadState -> Annex a) -> Annex a
withThreadState a = do
	state <- Annex.getState id
	mvar <- liftIO $ newMVar state
	r <- a mvar
	newstate <- liftIO $ takeMVar mvar
	Annex.changeState (const newstate)
	return r

{- Runs an Annex action, using the state from the MVar.
 -
 - This serializes calls by threads; only one thread can run in Annex at a
 - time. -}
runThreadState :: ThreadState -> Annex a -> IO a
runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a


code:
{- git-annex assistant pending transfer queue
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Types.TransferQueue where

import Common.Annex
import Logs.Transfer

import Control.Concurrent.STM
import Utility.TList

data TransferQueue = TransferQueue
	{ queuesize :: TVar Int
	, queuelist :: TList (Transfer, TransferInfo)
	, deferreddownloads :: TList (Key, AssociatedFile)
	}

data Schedule = Next | Later
	deriving (Eq)

newTransferQueue :: IO TransferQueue
newTransferQueue = atomically $ TransferQueue
	<$> newTVar 0
	<*> newTList
	<*> newTList


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

{-# LANGUAGE DeriveDataTypeable #-}

module Assistant.Types.TransferSlots where

import qualified Control.Exception as E
import qualified Control.Concurrent.MSemN as MSemN
import Data.Typeable

type TransferSlots = MSemN.MSemN Int

{- A special exception that can be thrown to pause or resume a transfer, while
 - keeping its slot in use. -}
data TransferException = PauseTransfer | ResumeTransfer
	deriving (Show, Eq, Typeable)

instance E.Exception TransferException

{- Number of concurrent transfers allowed to be run from the assistant.
 -
 - Transfers launched by other means, including by remote assistants,
 - do not currently take up slots.
 -}
numSlots :: Int
numSlots = 1

newTransferSlots :: IO TransferSlots
newTransferSlots = MSemN.new numSlots


code:
{- A pool of "git-annex transferkeys" processes available for use
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Types.TransferrerPool where

import Common.Annex
import Utility.NotificationBroadcaster
import Assistant.Types.DaemonStatus

import Control.Concurrent.STM hiding (check)

{- This TMVar is never left empty. -}
type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])

type CheckTransferrer = IO Bool
type MkCheckTransferrer = IO (IO Bool)

{- Each item in the pool may have a transferrer running, and has an
 - IO action that can be used to check if it's still ok to use the
 - transferrer. -}
data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer

data Transferrer = Transferrer
	{ transferrerRead :: Handle
	, transferrerWrite :: Handle
	, transferrerHandle :: ProcessHandle
	}

newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
newTransferrerPool c = newTMVarIO (c, [])

popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
popTransferrerPool p = do
	(c, l) <- takeTMVar p
	case l of
		[] -> do
			putTMVar p (c, [])
			return (Nothing, 0)
		(i:is) -> do
			putTMVar p (c, is)
			return $ (Just i, length is)

pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
pushTransferrerPool p i = do
	(c, l) <- takeTMVar p
	let l' = i:l
	putTMVar p (c, l')

{- Note that making a CheckTransferrer may allocate resources,
 - such as a NotificationHandle, so it's important that the returned
 - TransferrerPoolItem is pushed into the pool, and not left to be
 - garbage collected. -}
mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem
mkTransferrerPoolItem p t = do
	mkcheck <- atomically $ fst <$> readTMVar p
	check <- mkcheck
	return $ TransferrerPoolItem (Just t) check

checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
checkNetworkConnections dstatushandle = do
	dstatus <- atomically $ readTMVar dstatushandle
	h <- newNotificationHandle False (networkConnectedNotifier dstatus)
	return $ not <$> checkNotification h


code:
{- webapp url renderer access from the assistant
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Types.UrlRenderer (
	UrlRenderer,
	newUrlRenderer
) where

#ifdef WITH_WEBAPP

import Assistant.WebApp (UrlRenderer, newUrlRenderer)

#else

data UrlRenderer = UrlRenderer -- dummy type

newUrlRenderer :: IO UrlRenderer
newUrlRenderer = return UrlRenderer

#endif


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

{-# LANGUAGE OverloadedStrings #-}

module Assistant.Unused where

import qualified Data.Map as M

import Assistant.Common
import qualified Git
import Types.Key
import Logs.Unused
import Logs.Location
import Annex.Content
import Utility.DataUnits
import Utility.DiskFree
import Utility.HumanTime
import Utility.Tense

import Data.Time.Clock.POSIX
import qualified Data.Text as T

describeUnused :: Assistant (Maybe TenseText)
describeUnused = describeUnused' False

describeUnusedWhenBig :: Assistant (Maybe TenseText)
describeUnusedWhenBig = describeUnused' True

{- This uses heuristics: 1000 unused keys, or more unused keys
 - than the remaining free disk space, or more than 1/10th the total
 - disk space being unused keys all suggest a problem. -}
describeUnused' :: Bool -> Assistant (Maybe TenseText)
describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
  where
	go m = do
		let num = M.size m
		let diskused = foldl' sumkeysize 0 (M.keys m)
		df <- forpath getDiskFree
		disksize <- forpath getDiskSize
		return $ if num == 0
			then Nothing
			else if not whenbig || moreused df diskused || tenthused disksize diskused
				then Just $ tenseWords
					[ UnTensed $ T.pack $ roughSize storageUnits False diskused
					, Tensed "are" "were"
					, "taken up by unused files"
					]
				else if num > 1000
					then Just $ tenseWords
						[ UnTensed $ T.pack $ show num ++ " unused files"
						, Tensed "exist" "existed"
						]
					else Nothing

	moreused Nothing _ = False
	moreused (Just df) used = df <= used

	tenthused Nothing _ = False
	tenthused (Just disksize) used = used >= disksize `div` 10

	sumkeysize s k = s + fromMaybe 0 (keySize k)

	forpath a = inRepo $ liftIO . a . Git.repoPath

{- With a duration, expires all unused files that are older.
 - With Nothing, expires *all* unused files. -}
expireUnused :: Maybe Duration -> Assistant ()
expireUnused duration = do
	m <- liftAnnex $ readUnusedLog ""
	now <- liftIO getPOSIXTime
	let oldkeys = M.keys $ M.filter (tooold now) m
	forM_ oldkeys $ \k -> do
		debug ["removing old unused key", key2file k]
		liftAnnex $ do
			removeAnnex k
			logStatus k InfoMissing
  where
	boundry = durationToPOSIXTime <$> duration
	tooold now (_, mt) = case boundry of
		Nothing -> True
		Just b -> maybe False (\t -> now - t >= b) mt


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

{-# LANGUAGE CPP #-}

module Assistant.Upgrade where

import Assistant.Common
import Assistant.Restart
import qualified Annex
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Env
import Types.Distribution
import Logs.Transfer
import Logs.Web
import Logs.Presence
import Logs.Location
import Annex.Content
import qualified Backend
import qualified Types.Backend
import qualified Types.Key
import Assistant.TransferQueue
import Assistant.TransferSlots
import Remote (remoteFromUUID)
import Annex.Path
import Config.Files
import Utility.ThreadScheduler
import Utility.Tmp
import Utility.UserInfo
import Utility.Gpg
import Utility.FileMode
import qualified Utility.Lsof as Lsof
import qualified Build.SysConfig
import qualified Utility.Url as Url
import qualified Annex.Url as Url

import qualified Data.Map as M
import Data.Tuple.Utils

{- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant ()
unattendedUpgrade = do
	prepUpgrade
	url <- runRestart
	postUpgrade url

prepUpgrade :: Assistant ()
prepUpgrade = do
	void $ addAlert upgradingAlert
	void $ liftIO $ setEnv upgradedEnv "1" True
	prepRestart

postUpgrade :: URLString -> Assistant ()
postUpgrade = postRestart

autoUpgradeEnabled :: Assistant Bool
autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig

checkSuccessfulUpgrade :: IO Bool
checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv

upgradedEnv :: String
upgradedEnv = "GIT_ANNEX_UPGRADED"

{- Start downloading the distribution key from the web.
 - Install a hook that will be run once the download is complete,
 - and finishes the upgrade.
 -
 - Creates the destination directory where the upgrade will be installed
 - early, in order to check if another upgrade has happened (or is
 - happending). On failure, the directory is removed.
 -}
startDistributionDownload :: GitAnnexDistribution -> Assistant ()
startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
  where
  	go Nothing = debug ["Skipping redundant upgrade"]
	go (Just dest) = do
		liftAnnex $ setUrlPresent k u
		hook <- asIO1 $ distributionDownloadComplete d dest cleanup
		modifyDaemonStatus_ $ \s -> s
			{ transferHook = M.insert k hook (transferHook s) }
		maybe noop (queueTransfer "upgrade" Next (Just f) t)
			=<< liftAnnex (remoteFromUUID webUUID)
		startTransfer t
	k = distributionKey d
	u = distributionUrl d
	f = takeFileName u ++ " (for upgrade)"
	t = Transfer
		{ transferDirection = Download
		, transferUUID = webUUID
		, transferKey = k
		}
	cleanup = liftAnnex $ do
		removeAnnex k
		setUrlMissing k u
		logStatus k InfoMissing

{- Called once the download is done.
 - Passed an action that can be used to clean up the downloaded file.
 -
 - Fsck the key to verify the download.
 -}
distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
distributionDownloadComplete d dest cleanup t
	| transferDirection t == Download = do
		debug ["finished downloading git-annex distribution"]
		maybe (failedupgrade "bad download") go
			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
	| otherwise = cleanup
  where
	k = distributionKey d
	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of
		Nothing -> return $ Just f
		Just b -> case Types.Backend.fsckKey b of
			Nothing -> return $ Just f
			Just a -> ifM (a k f)
				( return $ Just f
				, return Nothing
				)
	go f = do
		ua <- asIO $ upgradeToDistribution dest cleanup f
		fa <- asIO1 failedupgrade
		liftIO $ ua `catchNonAsync` (fa . show)
	failedupgrade msg = do
		void $ addAlert $ upgradeFailedAlert msg
		cleanup
		liftIO $ void $ tryIO $ removeDirectoryRecursive dest

{- The upgrade method varies by OS.
 -
 - In general, find where the distribution was installed before,
 - and unpack the new distribution next to it (in a versioned directory).
 - Then update the programFile to point to the new version.
 -}
upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
upgradeToDistribution newdir cleanup distributionfile = do
	liftIO $ createDirectoryIfMissing True newdir
	(program, deleteold) <- unpack
	changeprogram program
	cleanup
	prepUpgrade
	url <- runRestart
	{- At this point, the new assistant is fully running, so
	 - it's safe to delete the old version. -}
	liftIO $ void $ tryIO deleteold
	postUpgrade url
  where
	changeprogram program = liftIO $ do
		unlessM (boolSystem program [Param "version"]) $
			error "New git-annex program failed to run! Not using."
		pf <- programFile
		liftIO $ writeFile pf program

#ifdef darwin_HOST_OS
	{- OS X uses a dmg, so mount it, and copy the contents into place. -}
	unpack = liftIO $ do
		olddir <- oldVersionLocation
		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
			void $ boolSystem "hdiutil"
				[ Param "attach", File distributionfile
				, Param "-mountpoint", File tmpdir
				]
			void $ boolSystem "cp"
				[ Param "-R"
				, File $ tmpdir </> installBase </> "Contents"
				, File $ newdir
				]
			void $ boolSystem "hdiutil"
				[ Param "eject"
				, File tmpdir
				]
			sanitycheck newdir
		let deleteold = do
			deleteFromManifest $ olddir </> "Contents" </> "MacOS"
			makeorigsymlink olddir
		return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
#else
	{- Linux uses a tarball (so could other POSIX systems), so
	 - untar it (into a temp directory) and move the directory
	 - into place. -}
	unpack = liftIO $ do
		olddir <- oldVersionLocation
		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
			let tarball = tmpdir </> "tar"
			-- Cannot rely on filename extension, and this also
			-- avoids problems if tar doesn't support transparent
			-- decompression.
			void $ boolSystem "sh"
				[ Param "-c"
				, Param $ "zcat < " ++ shellEscape distributionfile ++
					" > " ++ shellEscape tarball
				]
			tarok <- boolSystem "tar"
				[ Param "xf"
				, Param tarball
				, Param "--directory", File tmpdir
				]
			unless tarok $
				error $ "failed to untar " ++ distributionfile
			sanitycheck $ tmpdir </> installBase
			installby rename newdir (tmpdir </> installBase)
		let deleteold = do
			deleteFromManifest olddir
			makeorigsymlink olddir
		return (newdir </> "git-annex", deleteold)
	installby a dstdir srcdir =
		mapM_ (\x -> a x (dstdir </> takeFileName x))
			=<< dirContents srcdir
#endif
	sanitycheck dir =
		unlessM (doesDirectoryExist dir) $
			error $ "did not find " ++ dir ++ " in " ++ distributionfile
	makeorigsymlink olddir = do
		let origdir = parentDir olddir </> installBase
		nukeFile origdir
		createSymbolicLink newdir origdir

{- Finds where the old version was installed. -}
oldVersionLocation :: IO FilePath
oldVersionLocation = do
	pdir <- parentDir <$> readProgramFile
#ifdef darwin_HOST_OS
	let dirs = splitDirectories pdir
	{- It will probably be deep inside a git-annex.app directory. -}
	let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
		Nothing -> pdir
		Just i -> joinPath (take (i + 1) dirs)
#else
	let olddir = pdir
#endif
	when (null olddir) $
		error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
	return olddir

{- Finds a place to install the new version.
 - Generally, put it in the parent directory of where the old version was
 - installed, and use a version number in the directory name.
 - If unable to write to there, instead put it in the home directory.
 -
 - The directory is created. If it already exists, returns Nothing.
 -}
newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
newVersionLocation d olddir =
	trymkdir newloc $ do
		home <- myHomeDir
		trymkdir (home </> s) $
			return Nothing
  where
	s = installBase ++ "." ++ distributionVersion d
	topdir = parentDir olddir
	newloc = topdir </> s
	trymkdir dir fallback =
		(createDirectory dir >> return (Just dir))
			`catchIO` const fallback

installBase :: String
installBase = "git-annex." ++
#ifdef linux_HOST_OS
	"linux"
#else
#ifdef darwin_HOST_OS
	"app"
#else
	"dir"
#endif
#endif

deleteFromManifest :: FilePath -> IO ()
deleteFromManifest dir = do
	fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
	mapM_ nukeFile fs
	nukeFile manifest
	removeEmptyRecursive dir
  where
	manifest = dir </> "git-annex.MANIFEST"

removeEmptyRecursive :: FilePath -> IO ()
removeEmptyRecursive dir = do
	mapM_ removeEmptyRecursive =<< dirContents dir
	void $ tryIO $ removeDirectory dir

{- This is a file that the UpgradeWatcher can watch for modifications to
 - detect when git-annex has been upgraded.
 -}
upgradeFlagFile :: IO (Maybe FilePath)
upgradeFlagFile = ifM usingDistribution
	( Just <$> programFile
	, programPath
	)

{- Sanity check to see if an upgrade is complete and the program is ready
 - to be run. -}
upgradeSanityCheck :: IO Bool
upgradeSanityCheck = ifM usingDistribution
	( doesFileExist =<< programFile
	, do
		-- Ensure that the program is present, and has no writers,
		-- and can be run. This should handle distribution
		-- upgrades, manual upgrades, etc.
		v <- programPath
		case v of
			Nothing -> return False
			Just program -> do
				untilM (doesFileExist program <&&> nowriter program) $
					threadDelaySeconds (Seconds 60)
				boolSystem program [Param "version"]
	)
  where
	nowriter f = null
		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
		. map snd3
		<$> Lsof.query [f]

usingDistribution :: IO Bool
usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"

downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
downloadDistributionInfo = do
	uo <- liftAnnex Url.getUrlOptions
	liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
		let infof = tmpdir </> "info"
		let sigf = infof ++ ".sig"
		ifM (Url.downloadQuiet distributionInfoUrl infof uo
			<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo
			<&&> verifyDistributionSig sigf)
			( readish <$> readFileStrict infof
			, return Nothing
			)

distributionInfoUrl :: String
distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

distributionInfoSigUrl :: String
distributionInfoSigUrl = distributionInfoUrl ++ ".sig"

{- Verifies that a file from the git-annex distribution has a valid
 - signature. Pass the detached .sig file; the file to be verified should
 - be located next to it.
 -
 - The gpg keyring used to verify the signature is located in
 - trustedkeys.gpg, next to the git-annex program.
 -}
verifyDistributionSig :: FilePath -> IO Bool
verifyDistributionSig sig = do
	p <- readProgramFile
	if isAbsolute p
		then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
			let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
			boolSystem gpgcmd
				[ Param "--no-default-keyring"
				, Param "--no-auto-check-trustdb"
				, Param "--no-options"
				, Param "--homedir"
				, File gpgtmp
				, Param "--keyring"
				, File trustedkeys
				, Param "--verify"
				, File sig
				]
		else return False


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

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

module Assistant.WebApp where

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

import Data.Text (Text)
import Control.Concurrent
import qualified Network.Wai as W
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T

waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler ()
waitNotifier getbroadcaster nid = liftAssistant $ do
	b <- getbroadcaster
	liftIO $ waitNotification $ notificationHandleFromId b nid

newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
newNotifier getbroadcaster = liftAssistant $ do
	b <- getbroadcaster
	liftIO $ notificationHandleToId <$> newNotificationHandle True b

{- Adds the auth parameter as a hidden field on a form. Must be put into
 - every form. -}
webAppFormAuthToken :: Widget
webAppFormAuthToken = do
	webapp <- liftH getYesod
	[whamlet|<input type="hidden" name="auth" value="#{fromAuthToken (authToken webapp)}">|]

{- A button with an icon, and maybe label or tooltip, that can be
 - clicked to perform some action.
 - With javascript, clicking it POSTs the Route, and remains on the same
 - page.
 - With noscript, clicking it GETs the Route. -}
actionButton :: Route WebApp -> (Maybe String) -> (Maybe String) -> String -> String -> Widget
actionButton route label tooltip buttonclass iconclass = $(widgetFile "actionbutton")

type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text
type UrlRenderer = MVar (UrlRenderFunc)

newUrlRenderer :: IO UrlRenderer
newUrlRenderer = newEmptyMVar

setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO ()
setUrlRenderer = putMVar

inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod

{- Blocks until the webapp is running and has called setUrlRenderer. -}
renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
renderUrl urlrenderer route params = do
	r <- readMVar urlrenderer
	return $ r route params

{- Redirects back to the referring page, or if there's none, DashboardR -}
redirectBack :: Handler ()
redirectBack = do
	mr <- lookup "referer" . W.requestHeaders <$> waiRequest
	case mr of
		Nothing -> redirect DashboardR
		Just r -> redirect $ T.pack $ S8.unpack r


code:
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- | Helper functions for creating forms when using Bootstrap v3.
-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
-- modified to be compatible with Yesod 1.0.1
module Assistant.WebApp.Bootstrap3
  ( -- * Rendering forms
    renderBootstrap3
  , BootstrapFormLayout(..)
  , BootstrapGridOptions(..)
    -- * Field settings
  , bfs
  , withPlaceholder
  , withAutofocus
  , withLargeInput
  , withSmallInput
    -- * Submit button
  , bootstrapSubmit
  , mbootstrapSubmit
  , BootstrapSubmit(..)
  ) where

import Control.Arrow (second)
import Control.Monad (liftM)
import Data.Text (Text)
import Data.String (IsString(..))
import Yesod.Core

import qualified Data.Text as T

import Yesod.Form.Types
import Yesod.Form.Functions

-- | Create a new 'FieldSettings' with the classes that are
-- required by Bootstrap v3.
--
-- Since: yesod-form 1.3.8
bfs :: RenderMessage site msg => msg -> FieldSettings site
bfs msg =
    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]

-- | Add a placeholder attribute to a field.  If you need i18n
-- for the placeholder, currently you\'ll need to do a hack and
-- use 'getMessageRender' manually.
--
-- Since: yesod-form 1.3.8
withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
    where newAttrs = ("placeholder", placeholder) : fsAttrs fs

-- | Add an autofocus attribute to a field.
--
-- Since: yesod-form 1.3.8
withAutofocus :: FieldSettings site -> FieldSettings site
withAutofocus fs = fs { fsAttrs = newAttrs }
    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs

-- | Add the @input-lg@ CSS class to a field.
--
-- Since: yesod-form 1.3.8
withLargeInput :: FieldSettings site -> FieldSettings site
withLargeInput fs = fs { fsAttrs = newAttrs }
    where newAttrs = addClass "input-lg" (fsAttrs fs)

-- | Add the @input-sm@ CSS class to a field.
--
-- Since: yesod-form 1.3.8
withSmallInput :: FieldSettings site -> FieldSettings site
withSmallInput fs = fs { fsAttrs = newAttrs }
    where newAttrs = addClass "input-sm" (fsAttrs fs)

addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
addClass klass []                    = [("class", klass)]
addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
addClass klass (other         :rest) = other : addClass klass rest

-- | How many bootstrap grid columns should be taken (see
-- 'BootstrapFormLayout').
--
-- Since: yesod-form 1.3.8
data BootstrapGridOptions =
    ColXs !Int
  | ColSm !Int
  | ColMd !Int
  | ColLg !Int
    deriving (Eq, Ord, Show)

toColumn :: BootstrapGridOptions -> String
toColumn (ColXs 0) = ""
toColumn (ColSm 0) = ""
toColumn (ColMd 0) = ""
toColumn (ColLg 0) = ""
toColumn (ColXs columns) = "col-xs-" ++ show columns
toColumn (ColSm columns) = "col-sm-" ++ show columns
toColumn (ColMd columns) = "col-md-" ++ show columns
toColumn (ColLg columns) = "col-lg-" ++ show columns

toOffset :: BootstrapGridOptions -> String
toOffset (ColXs 0) = ""
toOffset (ColSm 0) = ""
toOffset (ColMd 0) = ""
toOffset (ColLg 0) = ""
toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
toOffset (ColMd columns) = "col-md-offset-" ++ show columns
toOffset (ColLg columns) = "col-lg-offset-" ++ show columns

addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
addGO (ColXs a) (ColXs b) = ColXs (a+b)
addGO (ColSm a) (ColSm b) = ColSm (a+b)
addGO (ColMd a) (ColMd b) = ColMd (a+b)
addGO (ColLg a) (ColLg b) = ColLg (a+b)
addGO a b     | a > b = addGO b a
addGO (ColXs a) other = addGO (ColSm a) other
addGO (ColSm a) other = addGO (ColMd a) other
addGO (ColMd a) other = addGO (ColLg a) other
addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"

-- | The layout used for the bootstrap form.
--
-- Since: yesod-form 1.3.8
data BootstrapFormLayout =
    BootstrapBasicForm
  | BootstrapInlineForm
  | BootstrapHorizontalForm
      { bflLabelOffset :: !BootstrapGridOptions
      , bflLabelSize   :: !BootstrapGridOptions
      , bflInputOffset :: !BootstrapGridOptions
      , bflInputSize   :: !BootstrapGridOptions
      }
    deriving (Show)

-- | Render the given form using Bootstrap v3 conventions.
--
-- Sample Hamlet for 'BootstrapHorizontalForm':
--
-- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
-- >    ^{formWidget}
-- >    ^{bootstrapSubmit MsgSubmit}
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
#else
renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
#endif
renderBootstrap3 formLayout aform fragment = do
    (res, views') <- aFormToForm aform
    let views = views' []
        has (Just _) = True
        has Nothing  = False
        widget = [whamlet|
#if MIN_VERSION_yesod(1,2,0)
            $newline never
#endif
            #{fragment}
            $forall view <- views
              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
                $case formLayout
                  $of BootstrapBasicForm
                    $if nequals (fvId view) bootstrapSubmitId
                      <label for=#{fvId view}>#{fvLabel view}
                    ^{fvInput view}
                    ^{helpWidget view}
                  $of BootstrapInlineForm
                    $if nequals (fvId view) bootstrapSubmitId
                      <label .sr-only for=#{fvId view}>#{fvLabel view}
                    ^{fvInput view}
                    ^{helpWidget view}
                  $of BootstrapHorizontalForm _a _b _c _d
                    $if nequals (fvId view) bootstrapSubmitId
                      <label .control-label .#{toOffset (bflLabelOffset formLayout)} .#{toColumn (bflLabelSize formLayout)} for=#{fvId view}>#{fvLabel view}
                      <div .#{toOffset (bflInputOffset formLayout)} .#{toColumn (bflInputSize formLayout)}>
                        ^{fvInput view}
                        ^{helpWidget view}
                    $else
                      <div .#{toOffset (addGO (bflInputOffset formLayout) (addGO (bflLabelOffset formLayout) (bflLabelSize formLayout)))} .#{toColumn (bflInputSize formLayout)}>
                        ^{fvInput view}
                        ^{helpWidget view}
                |]
    return (res, widget)
  where
    nequals a b = a /= b -- work around older hamlet versions not liking /=

-- | (Internal) Render a help widget for tooltips and errors.
#if MIN_VERSION_yesod(1,2,0)
helpWidget :: FieldView site -> WidgetT site IO ()
#else
helpWidget :: FieldView sub master -> GWidget sub master ()
#endif
helpWidget view = [whamlet|
    $maybe tt <- fvTooltip view
      <span .help-block>#{tt}
    $maybe err <- fvErrors view
      <span .help-block>#{err}
|]

-- | How the 'bootstrapSubmit' button should be rendered.
--
-- Since: yesod-form 1.3.8
data BootstrapSubmit msg =
    BootstrapSubmit
        { bsValue   :: msg
          -- ^ The text of the submit button.
        , bsClasses :: Text
          -- ^ Classes added to the @<button>@.
        , bsAttrs   :: [(Text, Text)]
          -- ^ Attributes added to the @<button>@.
        } deriving (Show)

instance IsString msg => IsString (BootstrapSubmit msg) where
    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []

-- | A Bootstrap v3 submit button disguised as a field for
-- convenience.  For example, if your form currently is:
--
-- > Person <$> areq textField "Name"    Nothing
-- >        <*> areq textField "Surname" Nothing
--
-- Then just change it to:
--
-- > Person <$> areq textField "Name"    Nothing
-- >        <*> areq textField "Surname" Nothing
-- >        <*  bootstrapSubmit "Register"
--
-- (Note that @<*@ is not a typo.)
--
-- Alternatively, you may also just create the submit button
-- manually as well in order to have more control over its
-- layout.
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
bootstrapSubmit
    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
    => BootstrapSubmit msg -> AForm m ()
#else
bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
#endif
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit

-- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
-- as useful since you're not going to use 'renderBootstrap3'
-- anyway.
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
mbootstrapSubmit
    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
#else
mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
#endif
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
    let res = FormSuccess ()
        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
        fv  = FieldView { fvLabel    = ""
                        , fvTooltip  = Nothing
                        , fvId       = bootstrapSubmitId
                        , fvInput    = widget
                        , fvErrors   = Nothing
                        , fvRequired = False }
    in return (res, fv)

-- | A royal hack.  Magic id used to identify whether a field
-- should have no label.  A valid HTML4 id which is probably not
-- going to clash with any other id should someone use
-- 'bootstrapSubmit' outside 'renderBootstrap3'.
bootstrapSubmitId :: Text
bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"


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

{-# LANGUAGE CPP #-}

module Assistant.WebApp.Common (module X) where

import Assistant.Common as X
import Assistant.WebApp as X
import Assistant.WebApp.Page as X
import Assistant.WebApp.Form as X
import Assistant.WebApp.Types as X
import Assistant.WebApp.RepoId as X
#if MIN_VERSION_yesod(1,2,0)
import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
#else
import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
#endif
import Data.Text as X (Text)


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

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

module Assistant.WebApp.Configurators where

import Assistant.WebApp.Common
import Assistant.WebApp.RepoList
#ifdef WITH_XMPP
import Assistant.XMPP.Client
#endif

{- The main configuration screen. -}
getConfigurationR :: Handler Html
getConfigurationR = ifM inFirstRun
	( redirect FirstRepositoryR
	, page "Configuration" (Just Configuration) $ do
#ifdef WITH_XMPP
		xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds
#else
		let xmppconfigured = False
#endif
		$(widgetFile "configurators/main")
	)

getAddRepositoryR :: Handler Html
getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
	let repolist = repoListDisplay mainRepoSelector
	$(widgetFile "configurators/addrepository")

makeMiscRepositories :: Widget
makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")

makeCloudRepositories :: Widget
makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")

makeXMPPConnection :: Widget
makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection")

makeSshRepository :: Widget
makeSshRepository = $(widgetFile "configurators/addrepository/ssh")

makeConnectionRepositories :: Widget
makeConnectionRepositories = $(widgetFile "configurators/addrepository/connection")

makeArchiveRepositories :: Widget
makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive")