summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/Configurators/Pairing.hs
blob: 96c053b86dded8d5d4a8734dce44c5383250cd8c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
{- git-annex assistant webapp configurator for pairing
 -
 - Pairing works like this:
 -
 - * The user opens StartPairR, which prompts them for a secret.
 - * The user submits it. The pairing secret is stored for later.
 -   A PairReq is broadcast out.
 - * On another device, it's received, and that causes its webapp to 
 -   display an Alert.
 - * The user there clicks the button, which opens FinishPairR,
 -   which prompts them for the same secret.
 - * The secret is used to verify the PairReq. If it checks out,
 -   a PairAck is sent, and the other device adds the ssh key from the
 -   PairReq to its authorized_keys, and sets up the remote.
 - * The PairAck is received back at the device that started the process.
 -   It's verified using the stored secret. The ssh key from the PairAck
 -   is added. An Alert is displayed noting that the pairing has been set
 -   up. The pairing secret is removed to prevent anyone cracking the
 -   crypto. Syncing starts. A PairDone is sent.
 - * The PairDone is received, and an alert shown indicating pairing is
 -   done.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

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

module Assistant.WebApp.Configurators.Pairing where

import Assistant.Pairing
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
#ifdef WITH_PAIRING
import Assistant.Common
import Assistant.Pairing.Network
import Assistant.Ssh
import qualified Assistant.WebApp.Configurators.Ssh as Ssh
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
import Utility.Network
#endif

import Yesod
import Data.Text (Text)
#ifdef WITH_PAIRING
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as B
import Data.Char
import System.Posix.User
import qualified Control.Exception as E
import Control.Concurrent
#endif

getStartPairR :: Handler RepHtml
#ifdef WITH_PAIRING
getStartPairR = do
	keypair <- liftIO genSshKeyPair
	promptSecret Nothing $ startPairing PairReq keypair noop
#else
getStartPairR = noPairing
#endif

getFinishPairR :: PairMsg -> Handler RepHtml
#ifdef WITH_PAIRING
getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
	keypair <- setup
	startPairing PairAck keypair cleanup "" secret
	where
		pubkey = remoteSshPubKey $ pairMsgData msg
		setup  = do
			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
				error "failed setting up ssh authorized keys"
			keypair <- liftIO genSshKeyPair
			let d = pairMsgData msg
			besthostname <- liftIO $ bestHostName d
			let sshdata = SshData
				{ sshHostName = T.pack besthostname
				, sshUserName = Just (T.pack $ remoteUserName d)
				, sshDirectory = T.pack (remoteDirectory d)
				, sshRepoName = genSshRepoName besthostname (remoteDirectory d)
				, needsPubKey = True
				, rsyncOnly = False
				}
			sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
			void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair)
			return keypair
		cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote"
#else
getFinishPairR _ = noPairing
#endif

getInprogressPairR :: Text -> Handler RepHtml
#ifdef WITH_PAIRING
getInprogressPairR secret = pairPage $ do
	$(widgetFile "configurators/pairing/inprogress")
#else
getInprogressPairR _ = noPairing
#endif

#ifdef WITH_PAIRING

{- Starts pairing, at either the PairReq (initiating host) or 
 - PairAck (responding host) stage.
 -
 - Displays an alert, and starts a thread sending the pairing message,
 - which will continue running until the other host responds, or until
 - canceled by the user. If canceled by the user, runs the oncancel action.
 -
 - Redirects to the pairing in progress page.
 -}
startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget
startPairing stage keypair oncancel displaysecret secret = do
	dstatus <- daemonStatus <$> lift getYesod
	urlrender <- lift getUrlRender
	let homeurl = urlrender HomeR
	sender <- mksender
	liftIO $ do
		pip <- PairingInProgress secret
			<$> sendrequests sender dstatus homeurl
			<*> pure keypair
		oldpip <- modifyDaemonStatus dstatus $
			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
		maybe noop stopold oldpip
	lift $ redirect $ InprogressPairR displaysecret
	where
		mksender = do
			hostname <- liftIO getHostname
			username <- liftIO getUserName
			reldir <- fromJust . relDir <$> lift getYesod
			return $ multicastPairMsg $ \addr -> PairMsg $ mkVerifiable
				(stage, PairData hostname addr username reldir (sshPubKey keypair)) secret
		{- Sends pairing messages until the thread is killed,
		 - and shows an activity alert while doing it.
		 -
		 - The cancel button returns the user to the HomeR. This is
		 - not ideal, but they have to be sent somewhere, and could
		 - have been on a page specific to the in-process pairing
		 - that just stopped, so can't go back there.
		 -}
		sendrequests sender dstatus homeurl = forkIO $ do
			tid <- myThreadId
			let selfdestruct = AlertButton
				{ buttonLabel = "Cancel"
				, buttonUrl = homeurl
				, buttonAction = Just $ const $ do
					oncancel
					killThread tid
				}
			alertDuring dstatus (pairingAlert selfdestruct) $ do
				_ <- E.try sender :: IO (Either E.SomeException ())
				return ()
		stopold = killThread  . inProgressThreadId

data InputSecret = InputSecret { secretText :: Maybe Text }

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

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

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

getUserName :: IO String
getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)

pairPage :: Widget -> Handler RepHtml
pairPage w = bootstrap (Just Config) $ do
	sideBarDisplay
	setTitle "Pairing"
	w

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

#else

noPairing :: Handler RepHtml
noPairing = pairPage $
	$(widgetFile "configurators/pairing/disabled")

#endif