2 files changed, 0 insertions, 291 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
deleted file mode 100644
index 09eaf1fe8..000000000
--- a/Assistant/Threads/PairListener.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-{- git-annex assistant thread to listen for incoming pairing traffic
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Threads.PairListener where
-
-import Assistant.Common
-import Assistant.Pairing
-import Assistant.Pairing.Network
-import Assistant.Pairing.MakeRemote
-import Assistant.WebApp (UrlRenderer)
-import Assistant.WebApp.Types
-import Assistant.Alert
-import Assistant.DaemonStatus
-import Utility.ThreadScheduler
-import Git
-
-import Network.Multicast
-import Network.Socket
-import qualified Data.ByteString as B
-import qualified Data.ByteString.UTF8 as BU8
-import qualified Network.Socket.ByteString as B
-import qualified Data.Text as T
-
-pairListenerThread :: UrlRenderer -> NamedThread
-pairListenerThread urlrenderer = namedThread "PairListener" $ do
-	listener <- asIO1 $ go [] []
-	liftIO $ withSocketsDo $
-		runEvery (Seconds 60) $ void $ tryIO $ 
-			listener =<< getsock
-  where
-	{- Note this can crash if there's no network interface,
-	 - or only one like lo that doesn't support multicast. -}
-	getsock = multicastReceiver (multicastAddress IPv4AddrClass) pairingPort
-		
-	go reqs cache sock = liftIO (getmsg sock B.empty) >>= \msg -> case readish (BU8.toString msg) of
-		Nothing -> go reqs cache sock
-		Just m -> do
-			debug ["received", show msg]
-			(pip, verified) <- verificationCheck m
-				=<< (pairingInProgress <$> getDaemonStatus)
-			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
-			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
-			case (wrongstage, fromus, checkSane (pairMsgData m), pairMsgStage m) of
-				(_, True, _, _) -> do
-					debug ["ignoring message that looped back"]
-					go reqs cache sock
-				(_, _, False, _) -> do
-					liftAnnex $ warning $
-						"illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")"
-					go reqs cache sock
-				-- PairReq starts a pairing process, so a
-				-- new one is always heeded, even if
-				-- some other pairing is in process.
-				(_, _, _, PairReq) -> if m `elem` reqs
-					then go reqs (invalidateCache m cache) sock
-					else do
-						pairReqReceived verified urlrenderer m
-						go (m:take 10 reqs) (invalidateCache m cache) sock
-				(True, _, _, _) -> do
-					debug
-						["ignoring out of order message"
-						, show (pairMsgStage m)
-						, "expected"
-						, show (succ . inProgressPairStage <$> pip)
-						]
-					go reqs cache sock
-				(_, _, _, PairAck) -> do
-					cache' <- pairAckReceived verified pip m cache
-					go reqs cache' sock
-				(_,_ , _, PairDone) -> do
-					pairDoneReceived verified pip m
-					go reqs cache sock
-
-	{- As well as verifying the message using the shared secret,
-	 - check its UUID against the UUID we have stored. If
-	 - they're the same, someone is sending bogus messages,
-	 - which could be an attempt to brute force the shared secret. -}
-	verificationCheck _ Nothing = return (Nothing, False)
-	verificationCheck m (Just pip)
-		| not verified && sameuuid = do
-			liftAnnex $ warning
-				"detected possible pairing brute force attempt; disabled pairing"
-			stopSending pip
-			return (Nothing, False)
-		| otherwise = return (Just pip, verified && sameuuid)
-	  where
-		verified = verifiedPairMsg m pip
-		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
-
-	{- PairReqs invalidate the cache of recently finished pairings.
-	 - This is so that, if a new pairing is started with the
-	 - same secret used before, a bogus PairDone is not sent. -}
-	invalidateCache msg = filter (not . verifiedPairMsg msg)
-
-	getmsg sock c = do
-		(msg, _) <- B.recvFrom sock chunksz
-		if B.length msg < chunksz
-			then return $ c <> msg
-			else getmsg sock $ c <> msg
-	  where
-		chunksz = 1024
-
-{- Show an alert when a PairReq is seen. -}
-pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
-pairReqReceived True _ _ = noop -- ignore our own PairReq
-pairReqReceived False urlrenderer msg = do
-	button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
-	void $ addAlert $ pairRequestReceivedAlert repo button
-  where
-	repo = pairRepo msg
-
-{- When a verified PairAck is seen, a host is ready to pair with us, and has
- - already configured our ssh key. Stop sending PairReqs, finish the pairing,
- - and send a single PairDone. -}
-pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
-pairAckReceived True (Just pip) msg cache = do
-	stopSending pip
-	repodir <- repoPath <$> liftAnnex gitRepo
-	liftIO $ setupAuthorizedKeys msg repodir
-	finishedLocalPairing msg (inProgressSshKeyPair pip)
-	startSending pip PairDone $ multicastPairMsg
-		(Just 1) (inProgressSecret pip) (inProgressPairData pip)
-	return $ pip : take 10 cache
-{- A stale PairAck might also be seen, after we've finished pairing.
- - Perhaps our PairDone was not received. To handle this, we keep
- - a cache of recently finished pairings, and re-send PairDone in
- - response to stale PairAcks for them. -}
-pairAckReceived _ _ msg cache = do
-	let pips = filter (verifiedPairMsg msg) cache
-	unless (null pips) $
-		forM_ pips $ \pip ->
-			startSending pip PairDone $ multicastPairMsg
-				(Just 1) (inProgressSecret pip) (inProgressPairData pip)
-	return cache
-
-{- If we get a verified PairDone, the host has accepted our PairAck, and
- - has paired with us. Stop sending PairAcks, and finish pairing with them.
- -
- - TODO: Should third-party hosts remove their pair request alert when they
- - see a PairDone?
- - Complication: The user could have already clicked on the alert and be
- - entering the secret. Would be better to start a fresh pair request in this
- - situation.
- -}
-pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
-pairDoneReceived False _ _ = noop -- not verified
-pairDoneReceived True Nothing _ = noop -- not in progress
-pairDoneReceived True (Just pip) msg = do
-	stopSending pip
-	finishedLocalPairing msg (inProgressSshKeyPair pip)
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
deleted file mode 100644
index dfb631bc6..000000000
--- a/Assistant/Threads/WebApp.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{- git-annex assistant webapp thread
- -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
-{-# LANGUAGE ViewPatterns, OverloadedStrings #-}
-{-# 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.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.WebApp.Pairing
-import Assistant.Types.ThreadedMonad
-import Utility.WebApp
-import Utility.AuthToken
-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
-
-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
-		giveup "Sorry, --listen is not currently supported on Android"
-#endif
-	webapp <- WebApp
-		<$> pure assistantdata
-		<*> genAuthToken 128
-		<*> getreldir
-		<*> pure staticRoutes
-		<*> pure postfirstrun
-		<*> pure cannotrun
-		<*> pure noannex
-		<*> pure listenhost'
-		<*> newWormholePairingState
-	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
-	cert <- fromRepo gitAnnexWebCertificate
-	privkey <- fromRepo gitAnnexWebPrivKey
-	ifM (liftIO $ allM doesFileExist [cert, privkey])
-		( return $ Just $ TLS.tlsSettings cert privkey
-		, return Nothing
-		)