diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index b4861b20d8..ef7b66d5c2 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -8,13 +8,26 @@ module Assistant.Pairing where import Assistant.Common +import Utility.Verifiable import Network.Socket (HostName) -type SshPubKey = String -type HMACDigest = String -type UserName = String -type Secret = String +{- 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 + deriving (Eq, Read, Show) data HostInfo = HostInfo { hostName :: HostName @@ -22,35 +35,5 @@ data HostInfo = HostInfo } deriving (Eq, Read, Show) -data PairStage - {- "I'd like to pair with somebody who knows a secret. - - Here's my ssh key, and hostinfo, both verifiable with - - our shared secret." -} - = PairRequest - {- "I've checked your PairRequest, and like it; I set up - - your ssh key already. Here's mine, also verified, please set it - - up too, and start syncing!" -} - | PairAck - deriving (Eq, Read, Show) - -type PairMsg = Verifiable (PairStage, HostInfo, SshPubKey) - -mkPairMsg :: Secret -> PairStage -> HostInfo -> SshPubKey -> PairMsg -mkPairMsg secret pairstage hostinfo sshkey = mkVerifiable - (pairstage, hostinfo, sshkey) secret - -{- A value, verifiable using a HMAC digest to encrypt using a shared secret. -} -data Verifiable a = Verifiable - { val :: a - , digest :: HMACDigest - } - deriving (Eq, Read, Show) - -mkVerifiable :: Show a => a -> Secret -> Verifiable a -mkVerifiable a secret = Verifiable a (calcDigest (show a) secret) - -verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool -verified v secret = v == mkVerifiable (val v) secret - -calcDigest :: String -> Secret -> HMACDigest -calcDigest = undefined -- TODO +type SshPubKey = String +type UserName = String diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs new file mode 100644 index 0000000000..58218db2a5 --- /dev/null +++ b/Utility/Verifiable.hs @@ -0,0 +1,37 @@ +{- values verified using a shared secret + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Verifiable where + +import Data.Digest.Pure.SHA +import Data.ByteString.Lazy.UTF8 (fromString) +import qualified Data.ByteString.Lazy as L + +type Secret = L.ByteString +type HMACDigest = String + +{- A value, verifiable using a HMAC digest and a secret. -} +data Verifiable a = Verifiable + { val :: a + , digest :: HMACDigest + } + deriving (Eq, Read, Show) + +mkVerifiable :: Show a => a -> Secret -> Verifiable a +mkVerifiable a secret = Verifiable a (calcDigest (show a) secret) + +verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool +verified v secret = v == mkVerifiable (val v) secret + +calcDigest :: String -> Secret -> HMACDigest +calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v + +{- for quickcheck -} +prop_verifiable_sane :: String -> String -> Bool +prop_verifiable_sane a s = verified (mkVerifiable a secret) secret + where + secret = fromString s diff --git a/test.hs b/test.hs index 7e19150674..c27fa8a7b5 100644 --- a/test.hs +++ b/test.hs @@ -47,6 +47,7 @@ import qualified Utility.FileMode import qualified Utility.Gpg import qualified Build.SysConfig import qualified Utility.Format +import qualified Utility.Verifiable -- for quickcheck instance Arbitrary Types.Key.Key where @@ -89,6 +90,7 @@ quickcheck = TestLabel "quickcheck" $ TestList , qctest "prop_hmacWithCipher_sane" Crypto.prop_hmacWithCipher_sane , qctest "prop_TimeStamp_sane" Logs.UUIDBased.prop_TimeStamp_sane , qctest "prop_addLog_sane" Logs.UUIDBased.prop_addLog_sane + , qctest "prop_verifiable_sane" Utility.Verifiable.prop_verifiable_sane ] blackbox :: Test