mocked up wormhole pairing interface in webapp
This commit is contained in:
parent
794babf35a
commit
a196260924
9 changed files with 94 additions and 3 deletions
|
@ -31,6 +31,9 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
|
|||
makeCloudRepositories :: Widget
|
||||
makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
|
||||
|
||||
makeTorConnection :: Widget
|
||||
makeTorConnection = $(widgetFile "configurators/addrepository/torconnection")
|
||||
|
||||
makeSshRepository :: Widget
|
||||
makeSshRepository = $(widgetFile "configurators/addrepository/ssh")
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex assistant webapp configurator for pairing
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012,2016 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
@ -22,6 +22,7 @@ import Assistant.DaemonStatus
|
|||
import Utility.Verifiable
|
||||
#endif
|
||||
import Utility.UserInfo
|
||||
import qualified Utility.MagicWormhole as Wormhole
|
||||
import Git
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
@ -33,6 +34,38 @@ import qualified Control.Exception as E
|
|||
import Control.Concurrent
|
||||
#endif
|
||||
|
||||
data PairingWith = PairingWithSelf | PairingWithFriend
|
||||
|
||||
getStartTorPairFriendR :: Handler Html
|
||||
getStartTorPairFriendR = postStartTorPairR PairingWithFriend
|
||||
|
||||
getStartTorPairSelfR :: Handler Html
|
||||
getStartTorPairSelfR = postStartTorPairR PairingWithSelf
|
||||
|
||||
postStartTorPairFriendR :: Handler Html
|
||||
postStartTorPairFriendR = postStartTorPairR PairingWithFriend
|
||||
|
||||
postStartTorPairSelfR :: Handler Html
|
||||
postStartTorPairSelfR = postStartTorPairR PairingWithSelf
|
||||
|
||||
postStartTorPairR :: PairingWith -> Handler Html
|
||||
postStartTorPairR pairingwith = pairPage $ do
|
||||
let Just ourcode = Wormhole.mkCode "11-bannana-bananna" -- XXX tmp
|
||||
((result, form), enctype) <- liftH $
|
||||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
|
||||
areq wormholeCodeField (bfs codeprompt) Nothing
|
||||
case result of
|
||||
FormSuccess v -> error "TODO"
|
||||
_ -> showform form enctype ourcode
|
||||
where
|
||||
showform form enctype ourcode = $(widgetFile "configurators/pairing/tor/prompt")
|
||||
codeprompt = case pairingwith of
|
||||
PairingWithFriend -> "Your friend's pairing code"
|
||||
PairingWithSelf -> "The other device's pairing code"
|
||||
wormholeCodeField = checkBool (Wormhole.validCode . T.unpack)
|
||||
("That does not look like a valid code. Try again..." :: T.Text)
|
||||
textField
|
||||
|
||||
{- Starts local pairing. -}
|
||||
getStartLocalPairR :: Handler Html
|
||||
getStartLocalPairR = postStartLocalPairR
|
||||
|
|
|
@ -62,6 +62,9 @@
|
|||
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
|
||||
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
|
||||
|
||||
/config/repository/pair/tor/self/start StartTorPairSelfR GET POST
|
||||
/config/repository/pair/tor/friend/start StartTorPairFriendR GET POST
|
||||
|
||||
/config/repository/enable/rsync/#UUID EnableRsyncR GET POST
|
||||
/config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST
|
||||
/config/repository/enable/directory/#UUID EnableDirectoryR GET
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue