summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-08 00:26:47 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-08 00:27:27 -0400
commit3bee6b3c74cede7c9099e6bf298ffa585ebf3b80 (patch)
treec03eb6201f8967cb28d383dde805e19df9aa9c8c
parent92df8250fa7c6d8c36ca214e45c7b5a6c9d307a9 (diff)
yesod skelton and routes for pairing
yet more changes to pairing message data types
-rw-r--r--Assistant/Pairing.hs30
-rw-r--r--Assistant/Threads/WebApp.hs1
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs51
-rw-r--r--Assistant/WebApp/Types.hs1
-rw-r--r--Assistant/WebApp/routes3
5 files changed, 70 insertions, 16 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index ef7b66d5c..f384895bd 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -12,26 +12,24 @@ import Utility.Verifiable
import Network.Socket (HostName)
-{- Messages sent in pairing are all verifiable using a secret that
- - should be shared between the systems being paired. -}
-type PairMsg = Verifiable (PairStage, HostInfo, SshPubKey)
-
-mkPairMsg :: Secret -> PairStage -> HostInfo -> SshPubKey -> PairMsg
-mkPairMsg secret pairstage hostinfo sshkey = mkVerifiable
- (pairstage, hostinfo, sshkey) secret
-
-data PairStage
- {- "I'd like to pair with somebody who knows a secret.
- - Here's my ssh key, and hostinfo." -}
- = PairRequest
- {- "I've checked your PairRequest, and like it; I set up
- - your ssh key already. Here's mine." -}
- | PairAck
+{- "I'd like to pair with somebody who knows a secret." -}
+data PairReq = PairReq (Verifiable PairData)
deriving (Eq, Read, Show)
-data HostInfo = HostInfo
+{- "I've checked your PairReq, and like it.
+ - I set up your ssh key already. Here's mine for you to set up." -}
+data PairAck = PairAck (Verifiable PairData)
+ deriving (Eq, Read, Show)
+
+data PairMsg
+ = PairReqM PairReq
+ | PairAckM PairAck
+ deriving (Eq, Read, Show)
+
+data PairData = PairData
{ hostName :: HostName
, userName :: UserName
+ , sshPubKey :: Maybe SshPubKey
}
deriving (Eq, Read, Show)
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 73a4467cd..54627f38e 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -19,6 +19,7 @@ import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
+import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Documentation
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
new file mode 100644
index 000000000..f555b2905
--- /dev/null
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -0,0 +1,51 @@
+{- git-annex assistant webapp configurator for pairing
+ -
+ - Pairing works like this:
+ -
+ - * The user optns StartPairR, which prompts them for a secret.
+ - * The user submits it. A PairReq is broadcast out. The secret is
+ - stashed away in a list of known pairing secrets.
+ - * 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. Note that multiple other devices could also send PairAcks, and
+ - as long as they're valid, all those devices are paired with.
+ -
+ - 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.WebApp
+import Assistant.WebApp.Types
+import Assistant.WebApp.SideBar
+import Utility.Yesod
+import Assistant.WebApp.Configurators.Local
+import qualified Types.Remote as R
+import qualified Remote.Rsync as Rsync
+import qualified Command.InitRemote
+import Logs.UUID
+import Logs.Remote
+
+import Yesod
+import Data.Text (Text)
+import qualified Data.Text as T
+
+getStartPairR :: Handler RepHtml
+getStartPairR = undefined
+
+getFinishPairR :: PairReq -> Handler RepHtml
+getFinishPairR = undefined
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index 1406a6d26..b88e78d67 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -19,6 +19,7 @@ import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Alert
+import Assistant.Pairing
import Utility.NotificationBroadcaster
import Utility.WebApp
import Logs.Transfer
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 7ed1f30d3..5bab0cc63 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -11,6 +11,9 @@
/config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
/config/repository/add/rsync.net AddRsyncNetR GET
+/config/repository/pair/start StartPairR GET
+/config/repository/pair/finish/#PairReq FinishPairR GET
+
/config/repository/first FirstRepositoryR GET
/transfers/#NotificationId TransfersR GET