From 21c8df12517b0c3307ea9c8287321510cdfc926d Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 3 Feb 2019 11:12:18 +0000
Subject: [PATCH] Actor public key specifies whether it's shared

Shared key means the key is used for multiple actors. I'm not sure explicitly
specifying this will be necessary, but I prefer to have it in place to help
with debugging in case something unexpected comes from other servers, or my
format overlaps with stuff used in other software and encodes a different
meaning.

Each public key can specify whether it's shared or personal, and this patch
checks for that when verifying a request signature. It rejects shared keys,
accepting valid sigs only from personal keys.

Very soon I'll add shared key support.
---
 src/Vervis/Foundation.hs     |  3 +++
 src/Vervis/Handler/Person.hs |  9 +++++----
 src/Web/ActivityPub.hs       | 21 ++++++++++++---------
 3 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 41e0f1e..2e5f14f 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -584,6 +584,9 @@ instance YesodHttpSig App where
                 then Right ()
                 else Left "Actor ID doesn't match the keyid URI we fetched"
             let pkey = actorPublicKey actor
+            if publicKeyShared pkey
+                then Left "Actor's publicKey is shared, we're rejecting it!"
+                else Right ()
             if publicKeyId pkey == u
                 then Right ()
                 else Left "Actor's publicKey's ID doesn't match the keyid URI"
diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index 5b42bf9..59edcf7 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@@ -154,10 +154,11 @@ getPersonR shr = do
             , actorUsername  = shr2text shr
             , actorInbox     = route2uri InboxR
             , actorPublicKey = PublicKey
-                { publicKeyId    = me { uriFragment = "#key" }
-                , publicKeyOwner = me
-                , publicKeyPem   = PEM "PUBLIC KEY" [] actorKey
-                , publicKeyAlgo  = Just AlgorithmEd25519
+                { publicKeyId     = me { uriFragment = "#key" }
+                , publicKeyOwner  = me
+                , publicKeyPem    = PEM "PUBLIC KEY" [] actorKey
+                , publicKeyAlgo   = Just AlgorithmEd25519
+                , publicKeyShared = False
                 }
             }
 
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 3e811a6..4389727 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -108,10 +108,11 @@ instance ToJSON Algorithm where
             AlgorithmOther t -> t
 
 data PublicKey = PublicKey
-    { publicKeyId    :: URI
-    , publicKeyOwner :: URI
-    , publicKeyPem   :: PEM
-    , publicKeyAlgo  :: Maybe Algorithm
+    { publicKeyId     :: URI
+    , publicKeyOwner  :: URI
+    , publicKeyPem    :: PEM
+    , publicKeyAlgo   :: Maybe Algorithm
+    , publicKeyShared :: Bool
     }
 
 instance FromJSON PublicKey where
@@ -121,6 +122,7 @@ instance FromJSON PublicKey where
             <*> (parseHttpsURI =<< o .: "owner")
             <*> (parsePEM =<< o .: "publicKeyPem")
             <*> o .:? (frg <> "algorithm")
+            <*> o .:? (frg <> "shared") .!= False
         where
         parsePEM t =
             case pemParseBS $ encodeUtf8 t of
@@ -133,12 +135,13 @@ instance FromJSON PublicKey where
 
 instance ToJSON PublicKey where
     toJSON = error "toJSON PublicKey"
-    toEncoding (PublicKey id_ owner pem malgo) =
+    toEncoding (PublicKey id_ owner pem malgo shared) =
         pairs
-            $  "id"           .= renderURI id_
-            <> "owner"        .= renderURI owner
-            <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
-            <> maybe mempty ((frg <> "algorithm") .=) malgo
+            $  "id"                 .=  renderURI id_
+            <> "owner"              .=  renderURI owner
+            <> "publicKeyPem"       .=  decodeUtf8 (pemWriteBS pem)
+            <> (frg <> "algorithm") .=? malgo
+            <> (frg <> "shared")    .=  shared
 
 data Actor = Actor
     { actorId        :: URI