Added cryptonomic.net to --autosign and --import-if-authentic.

WARNING: UNTESTED.  This was quick and dirty and affects security
critical code.  Needs a little more attention.

1 files changed, 25 insertions, 6 deletions

diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 8adf6af..7e4d288 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -29,7 +29,7 @@ import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map.Strict      as Map
 import qualified Data.ByteString.Char8 as S8
 import Data.ByteArray.Encoding
-import qualified Crypto.Hash as Vincent
+import qualified Crypto.Hash as C
 import Data.ByteArray (convert)
 import Data.ASN1.BinaryEncoding ( DER(..) )
 import Data.ASN1.Types (toASN1, ASN1Object, fromASN1, ASN1(Start, End, IntVal), ASN1ConstructionType(Sequence) )
@@ -39,6 +39,7 @@ import qualified Data.Text as T ( Text, unpack, pack,
         strip, reverse, drop, break, dropAround, length, breakOn )
 import Data.Text.Encoding ( encodeUtf8 )
 import Data.Bits              ((.|.), (.&.), Bits)
+import qualified SSHKey as SSH
 
 
 data KeyRingRuntime = KeyRingRuntime
@@ -523,7 +524,7 @@ derToBase32 :: L.ByteString -> String
 derToBase32 = map toLower . base32 . sha1
  where
    sha1 :: L.ByteString -> S.ByteString
-   sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
+   sha1 x = convert (C.hashlazy x :: C.Digest C.SHA1)
    base32 = S8.unpack . convertToBase Base32
 
 derRSA :: Packet -> Maybe L.ByteString
@@ -776,10 +777,13 @@ parseUID str = UserIDRecord {
 
 selfAuthenticated :: OriginMapped Packet -> KeyData -> UidString -> Bool
 selfAuthenticated k kd (UidString str) =
-  and [ uid_topdomain parsed == "onion"
-      , uid_realname parsed `elem` ["","Anonymous"]
+  and [ uid_realname parsed `elem` ["","Anonymous"]
       , uid_user parsed == "root"
-      , fmap match torSubdom == Just True
+      , ( uid_topdomain parsed == "onion"
+              && fmap match torSubdom == Just True )
+        ||
+        ( uid_topdomain parsed == "ssh-rsa.cryptonomic.net"
+              && fmap match sshSubdom == Just True )
       ]
   where
     parsed      = parseUID str
@@ -787,8 +791,11 @@ selfAuthenticated k kd (UidString str) =
     len         = T.length (uid_subdomain parsed)
     subdom0     = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
     subdom      = Char8.unpack subdom0
+    keys        = map packet $ flattenTop "" True kd
     torSubdom   = fst <$> lookup (packet k) torbindings
-    torbindings = getTorKeys (map packet $ flattenTop "" True kd)
+    torbindings = getTorKeys keys
+    sshSubdom   = fst <$> lookup (packet k) hostbindings
+    hostbindings = getHostKeys keys
 
 getTorKeys :: [Packet] -> [(Packet, (String, Packet))]
 getTorKeys pub = do
@@ -798,6 +805,18 @@ getTorKeys pub = do
     let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
     return (top,(torhash,sub))
 
+getHostKeys :: [Packet] -> [(Packet, (String, Packet))]
+getHostKeys pub = do
+    xs <- groupBindings pub
+    (_,(top,sub),us,_,_) <- xs
+    guard ("ssh-host" `elem` us)
+    RSAKey (MPI n) (MPI e) <- maybeToList $ rsaKeyFromPacket sub
+    let blob = SSH.sshrsa e n
+        sha1 = C.hashlazy blob :: C.Digest C.SHA1
+        subdomain = convertToBase Base16 sha1
+    return (top,(S8.unpack subdomain,sub))
+
+
 groupBindings :: [Packet] -> [[(Word8, (Packet, Packet), [String], [SignatureSubpacket], [Packet])]]
 groupBindings (accBindings . snd . getBindings -> bindings) = gs
   where