Link to per-actor keys from actor documents

Per-actor keys are now fully supported in Vervis! Caveats:

- The HTTP Signature keys produced by Vervis are Ed25519 keys; software that
  expects only RSA keys will fail here
- Like instance keys, per-actor keys are currently served in separate
  documents, not embedded in the actor document; so software that expects
  embedded keys will fail here

src/Vervis/Handler/Deck.hs

@@ -118,12 +118,17 @@ import qualified Vervis.Client as C
 getDeckR :: KeyHashid Deck -> Handler TypedContent
 getDeckR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    (deck, repoIDs, actor) <- runDB $ do
+    (deck, repoIDs, actor, sigKeyIDs) <- runDB $ do
         d <- get404 deckID
         rs <- selectKeysList [RepoProject ==. Just deckID] [Asc RepoId]
-        (d,rs,) <$> getJust (deckActor d)
+        let aid = deckActor d
+        a <- getJust aid
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        return (d, rs, a, sigKeys)
 
     encodeRouteLocal <- getEncodeRouteLocal
+    hashSigKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
     let deckAP = AP.TicketTracker
             { AP.ticketTrackerActor = AP.Actor
                 { AP.actorLocal = AP.ActorLocal
@@ -135,9 +140,10 @@ getDeckR deckHash = do
                         Just $ encodeRouteLocal $ DeckFollowersR deckHash
                     , AP.actorFollowing  = Nothing
                     , AP.actorPublicKeys =
-                        [ Left $ encodeRouteLocal ActorKey1R
+                        map (Left . encodeRouteLocal) $
-                        , Left $ encodeRouteLocal ActorKey2R
+                        if perActor
-                        ]
+                            then map (DeckStampR deckHash . hashSigKey) sigKeyIDs
+                            else [ActorKey1R, ActorKey2R]
                     , AP.actorSshKeys    = []
                     }
                 , AP.actorDetail = AP.ActorDetail

src/Vervis/Handler/Group.hs

@@ -56,6 +56,7 @@ import Network.FedURI
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
@@ -64,16 +65,22 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
+import Vervis.Settings
 import Vervis.Web.Actor
 
 getGroupR :: KeyHashid Group -> Handler TypedContent
 getGroupR groupHash = do
     groupID <- decodeKeyHashid404 groupHash
-    (group, actor) <- runDB $ do
+    (group, actor, sigKeyIDs) <- runDB $ do
         g <- get404 groupID
-        (g,) <$> getJust (groupActor g)
+        let aid = groupActor g
+        a <- getJust aid
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        return (g, a, sigKeys)
 
     encodeRouteLocal <- getEncodeRouteLocal
+    hashSigKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
 
     let route mk = encodeRouteLocal $ mk groupHash
         groupAP = AP.Actor
@@ -84,9 +91,10 @@ getGroupR groupHash = do
                 , AP.actorFollowers  = Just $ route GroupFollowersR
                 , AP.actorFollowing  = Nothing
                 , AP.actorPublicKeys =
-                    [ Left $ encodeRouteLocal ActorKey1R
+                    map (Left . encodeRouteLocal) $
-                    , Left $ encodeRouteLocal ActorKey2R
+                    if perActor
-                    ]
+                        then map (GroupStampR groupHash . hashSigKey) sigKeyIDs
+                        else [ActorKey1R, ActorKey2R]
                 , AP.actorSshKeys    = []
                 }
             , AP.actorDetail = AP.ActorDetail

src/Vervis/Handler/Loom.hs

@@ -94,11 +94,16 @@ import qualified Vervis.Client as C
 getLoomR :: KeyHashid Loom -> Handler TypedContent
 getLoomR loomHash = do
     loomID <- decodeKeyHashid404 loomHash
-    (loom, actor) <- runDB $ do
+    (loom, actor, sigKeyIDs) <- runDB $ do
         l <- get404 loomID
-        (l,) <$> getJust (loomActor l)
+        let aid = loomActor l
+        a <- getJust aid
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        return (l, a, sigKeys)
 
     encodeRouteLocal <- getEncodeRouteLocal
+    hashSigKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
     let route mk = encodeRouteLocal $ mk loomHash
         loomAP = AP.Actor
             { AP.actorLocal = AP.ActorLocal
@@ -108,9 +113,10 @@ getLoomR loomHash = do
                 , AP.actorFollowers  = Just $ route LoomFollowersR
                 , AP.actorFollowing  = Nothing
                 , AP.actorPublicKeys =
-                    [ Left $ encodeRouteLocal ActorKey1R
+                    map (Left . encodeRouteLocal) $
-                    , Left $ encodeRouteLocal ActorKey2R
+                    if perActor
-                    ]
+                        then map (LoomStampR loomHash . hashSigKey) sigKeyIDs
+                        else [ActorKey1R, ActorKey2R]
                 , AP.actorSshKeys    = []
                 }
             , AP.actorDetail = AP.ActorDetail

src/Vervis/Handler/Person.hs

@@ -90,13 +90,17 @@ import Vervis.Widget.Person
 getPersonR :: KeyHashid Person -> Handler TypedContent
 getPersonR personHash = do
     personID <- decodeKeyHashid404 personHash
-    (person, actor, sshKeyIDs) <- runDB $ do
+    (person, actor, sigKeyIDs, sshKeyIDs) <- runDB $ do
         p <- get404 personID
-        a <- getJust $ personActor p
+        let aid = personActor p
-        ks <- selectKeysList [SshKeyPerson ==. personID] [Asc SshKeyId]
+        a <- getJust aid
-        return (p, a, ks)
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        sshKeys <- selectKeysList [SshKeyPerson ==. personID] [Asc SshKeyId]
+        return (p, a, sigKeys, sshKeys)
     encodeRouteLocal <- getEncodeRouteLocal
+    hashSigKey <- getEncodeKeyHashid
     hashSshKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
 
     let personAP = AP.Actor
             { AP.actorLocal = AP.ActorLocal
@@ -106,9 +110,10 @@ getPersonR personHash = do
                 , AP.actorFollowers  = Just $ encodeRouteLocal $ PersonFollowersR personHash
                 , AP.actorFollowing  = Just $ encodeRouteLocal $ PersonFollowingR personHash
                 , AP.actorPublicKeys =
-                    [ Left $ encodeRouteLocal ActorKey1R
+                    map (Left . encodeRouteLocal) $
-                    , Left $ encodeRouteLocal ActorKey2R
+                    if perActor
-                    ]
+                        then map (PersonStampR personHash . hashSigKey) sigKeyIDs
+                        else [ActorKey1R, ActorKey2R]
                 , AP.actorSshKeys    =
                     map (encodeRouteLocal . SshKeyR personHash . hashSshKey) sshKeyIDs
                 }

src/Vervis/Handler/Repo.hs

@@ -181,12 +181,17 @@ import qualified Vervis.Hook as H
 getRepoR :: KeyHashid Repo -> Handler TypedContent
 getRepoR repoHash = do
     repoID <- decodeKeyHashid404 repoHash
-    (repo, actor) <- runDB $ do
+    (repo, actor, sigKeyIDs) <- runDB $ do
         r <- get404 repoID
-        (r,) <$> getJust (repoActor r)
+        let aid = repoActor r
+        a <- getJust aid
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        return (r, a, sigKeys)
 
     encodeRouteLocal <- getEncodeRouteLocal
     hashLoom <- getEncodeKeyHashid
+    hashSigKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
     let repoAP = AP.Repo
             { AP.repoActor = AP.Actor
                 { AP.actorLocal = AP.ActorLocal
@@ -198,9 +203,10 @@ getRepoR repoHash = do
                         Just $ encodeRouteLocal $ RepoFollowersR repoHash
                     , AP.actorFollowing  = Nothing
                     , AP.actorPublicKeys =
-                        [ Left $ encodeRouteLocal ActorKey1R
+                        map (Left . encodeRouteLocal) $
-                        , Left $ encodeRouteLocal ActorKey2R
+                        if perActor
-                        ]
+                            then map (RepoStampR repoHash . hashSigKey) sigKeyIDs
+                            else [ActorKey1R, ActorKey2R]
                     , AP.actorSshKeys    = []
                     }
                 , AP.actorDetail = AP.ActorDetail