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
|
{- 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 #-}
module Assistant.WebApp.Configurators.Pairing where
import Assistant.Common
import Assistant.Pairing
import Assistant.DaemonStatus
import Utility.Verifiable
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import Yesod
import Data.Text (Text)
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
getStartPairR :: Handler RepHtml
getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
username <- liftIO $ getUserName
let sshkey = "" -- TODO generate/read ssh key
let mkmsg hostname = PairReqM $ PairReq $
mkVerifiable (PairData hostname 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
getInprogressPairR :: Text -> Handler RepHtml
getInprogressPairR secret = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Pairing"
$(widgetFile "configurators/inprogresspairing")
getFinishPairR :: PairReq -> Handler RepHtml
getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
error "TODO"
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 $ 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)
|
