summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/Configurators/Pairing.hs
blob: cc7d1cf77c592b7f3cb4a6309e52dfa8d08cd542 (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
{- 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. An Alert is displayed noting that the pairing has been set up.
 - * 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.
 -
 - 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
#ifdef WITH_PAIRING
import Assistant.Pairing.Network
import Assistant.Common
import Assistant.DaemonStatus
import Utility.Verifiable
import Utility.Network
#endif
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod

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
#endif

getStartPairR :: Handler RepHtml
#ifdef WITH_PAIRING
getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
	hostname <- liftIO $ getHostname
	username <- liftIO $ getUserName
	let sshkey = "" -- TODO generate/read ssh key
	let mkmsg addr = PairReqM $ PairReq $
		mkVerifiable (PairData hostname addr username sshkey) secret
	pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
	dstatus <- daemonStatus <$> lift getYesod
	liftIO $ modifyDaemonStatus_ dstatus $
		\s -> s { pairingInProgress = pip : pairingInProgress s }
	lift $ redirect $ InprogressPairR rawsecret
#else
getStartPairR = noPairing
#endif

getInprogressPairR :: Text -> Handler RepHtml
#ifdef WITH_PAIRING
getInprogressPairR secret = bootstrap (Just Config) $ do
	sideBarDisplay
	setTitle "Pairing"
	$(widgetFile "configurators/inprogresspairing")
#else
getInprogressPairR _ = noPairing
#endif

getFinishPairR :: PairReq -> Handler RepHtml
#ifdef WITH_PAIRING
getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
	error "TODO"
#else
getFinishPairR _ = noPairing
#endif

#ifdef WITH_PAIRING
data InputSecret = InputSecret { secretText :: Maybe Text }

promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
promptSecret req cont = bootstrap (Just Config) $ do
	sideBarDisplay
	setTitle "Pairing"
	((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 req of
				Nothing -> case secretProblem secret of
					Nothing -> cont rawsecret secret
					Just problem ->
						showform form enctype $ Just problem
				Just r ->
					if verified (fromPairReq r) 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 req
			let badphrase = isJust mproblem
			let msg = fromMaybe "" mproblem
			let (username, hostname) = maybe ("", "")
				(\v -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
				(verifiableVal . fromPairReq <$> req)
			u <- T.pack <$> liftIO getUserName
			let sameusername = username == u
                        let authtoken = webAppFormAuthToken
                        $(widgetFile "configurators/pairing")

{- 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]

{- 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."
	]

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

#else

noPairing :: Handler RepHtml
noPairing = bootstrap (Just Config) $ do
	sideBarDisplay
	setTitle "Pairing"
	$(widgetFile "configurators/nopairing")

#endif