1{- git-annex assistant repo pairing, core data types
2 -
3 - Copyright 2012 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Assistant.Pairing where
9
10import Annex.Common
11import Utility.Verifiable
12import Assistant.Ssh
13
14import Control.Concurrent
15import Network.Socket
16import Data.Char
17import qualified Data.Text as T
18
19data PairStage
20	{- "I'll pair with anybody who shares the secret that can be used
21	 - to verify this request." -}
22	 = PairReq
23	{- "I've verified your request, and you can verify this to see
24	 - that I know the secret. I set up your ssh key already.
25	 - Here's mine for you to set up." -}
26	| PairAck
27	{- "I saw your PairAck; you can stop sending them." -}
28	| PairDone
29	deriving (Eq, Read, Show, Ord, Enum)
30
31newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
32	deriving (Eq, Read, Show)
33
34verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
35verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
36
37fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
38fromPairMsg (PairMsg m) = m
39
40pairMsgStage :: PairMsg -> PairStage
41pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
42
43pairMsgData :: PairMsg -> PairData
44pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
45
46pairMsgAddr :: PairMsg -> SomeAddr
47pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
48
49data PairData = PairData
50	-- uname -n output, not a full domain name
51	{ remoteHostName :: Maybe HostName
52	, remoteUserName :: UserName
53	, remoteDirectory :: FilePath
54	, remoteSshPubKey :: SshPubKey
55	, pairUUID :: UUID
56	}
57	deriving (Eq, Read, Show)
58
59checkSane :: PairData -> Bool
60checkSane p = all (not . any isControl)
61	[ fromMaybe "" (remoteHostName p)
62	, remoteUserName p
63	, remoteDirectory p
64	, remoteSshPubKey p
65	, fromUUID (pairUUID p)
66	]
67
68type UserName = String
69
70{- A pairing that is in progress has a secret, a thread that is
71 - broadcasting pairing messages, and a SshKeyPair that has not yet been
72 - set up on disk. -}
73data PairingInProgress = PairingInProgress
74	{ inProgressSecret :: Secret
75	, inProgressThreadId :: Maybe ThreadId
76	, inProgressSshKeyPair :: SshKeyPair
77	, inProgressPairData :: PairData
78	, inProgressPairStage :: PairStage
79	}
80	deriving (Show)
81
82data AddrClass = IPv4AddrClass | IPv6AddrClass
83
84data SomeAddr = IPv4Addr HostAddress
85	| IPv6Addr HostAddress6
86	deriving (Ord, Eq, Read, Show)
87
88{- This contains the whole secret, just lightly obfuscated to make it not
89 - too obvious. It's only displayed in the user's web browser. -}
90newtype SecretReminder = SecretReminder [Int]
91	deriving (Show, Eq, Ord, Read)
92
93toSecretReminder :: T.Text -> SecretReminder
94toSecretReminder = SecretReminder . map ord . T.unpack
95
96fromSecretReminder :: SecretReminder -> T.Text
97fromSecretReminder (SecretReminder s) = T.pack $ map chr s
98