Store remote actor keys in the DB, reuse them instead of GETing every time

config/models

@@ -39,6 +39,12 @@ Person
     UniquePersonLogin login
     UniquePersonEmail email
 
+VerifKey
+    ident  URI
+    public PublicKey
+
+    UniqueVerifKey ident
+
 SshKey
     ident   KyIdent
     person  PersonId

migrations/2019_02_03_verifkey.model

@@ -0,0 +1,5 @@
+VerifKey
+    ident  String
+    public ByteString
+
+    UniqueVerifKey ident

src/Database/Persist/Class/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,7 +13,6 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
--- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields.
 module Database.Persist.Class.Local
     (
     )
@@ -21,11 +20,46 @@ where
 
 import Prelude
 
+import Control.Exception (displayException)
+import Control.Monad ((<=<))
+import Crypto.Error (CryptoFailable, eitherCryptoError)
+import Crypto.PubKey.Ed25519 (PublicKey, publicKey)
+import Data.Bifunctor (first)
+import Data.ByteArray (convert)
+import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import Database.Persist.Class
+import Network.URI (URI, uriScheme, parseURI)
 
 import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T (pack)
+
+import Data.Aeson.Local (renderURI)
 
 instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where
     toPersistValue = toPersistValue . CI.original
     fromPersistValue = fmap CI.mk . fromPersistValue
+
+instance PersistField URI where
+    toPersistValue = toPersistValue . renderURI
+    fromPersistValue = parseHttpsURI <=< fromPersistValue
+        where
+        parseHttpsURI s =
+            case parseURI s of
+                Nothing -> Left "Invalid absolute URI"
+                Just u ->
+                    if uriScheme u == "https:"
+                        then Right u
+                        else Left "URI scheme isn't https"
+
+instance PersistField PublicKey where
+    toPersistValue = toPersistValue . convert'
+        where
+        convert' :: PublicKey -> ByteString
+        convert' = convert
+    fromPersistValue = toKey <=< fromPersistValue
+        where
+        publicKey' :: ByteString -> CryptoFailable PublicKey
+        publicKey' = publicKey
+        toKey =
+            first (T.pack . displayException) . eitherCryptoError . publicKey'

src/Database/Persist/Sql/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -20,12 +20,26 @@ where
 
 import Prelude
 
+import Crypto.PubKey.Ed25519 (PublicKey)
+import Data.ByteArray (convert)
+import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import Database.Persist.Sql
+import Network.URI (URI)
 
 import qualified Data.CaseInsensitive as CI
 
+import Data.Aeson.Local (renderURI)
 import Database.Persist.Class.Local ()
 
 instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
     sqlType = sqlType . fmap CI.original
+
+instance PersistFieldSql URI where
+    sqlType = sqlType . fmap renderURI
+
+instance PersistFieldSql PublicKey where
+    sqlType = sqlType . fmap convert'
+        where
+        convert' :: PublicKey -> ByteString
+        convert' = convert

src/Vervis/Foundation.hs

@@ -576,46 +576,54 @@ instance YesodHttpSig App where
         u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
             Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
             Just uri -> Right uri
-        manager <- getsYesod appHttpManager
-        actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
+        let uActor = u { uriFragment = "" }
+        (fromDB, key) <- do
+            ment <- lift $ runDB $ getBy $ UniqueVerifKey u
+            case ment of
+                Just (Entity _ vk) -> return (True, verifKeyPublic vk)
+                Nothing -> do
+                    manager <- getsYesod appHttpManager
+                    actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
+                    ExceptT . pure $ do
+                        if uActor == actorId actor
+                            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"
+                        if publicKeyOwner pkey == actorId actor
+                            then Right ()
+                            else Left "Actor's publicKey's owner doesn't match the actor's ID"
+                        case publicKeyAlgo pkey of
+                            Nothing ->
+                                Left $
+                                case malgo of
+                                    Nothing -> "Algo not given in Sig nor actor"
+                                    Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
+                            Just algo ->
+                                case algo of
+                                    AlgorithmEd25519 -> Right ()
+                                    AlgorithmOther _ ->
+                                        Left $
+                                        case malgo of
+                                            Nothing -> "No algo in Sig, unsupported algo in actor"
+                                            Just _  -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
+                        case publicKey $ pemContent $ publicKeyPem pkey of
+                            CryptoPassed k -> Right (False, k)
+                            CryptoFailed e -> Left "Parsing Ed25519 public key failed"
         ExceptT . pure $ do
-            let uActor = u { uriFragment = "" }
-            if uActor == actorId actor
-                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"
-            if publicKeyOwner pkey == actorId actor
-                then Right ()
-                else Left "Actor's publicKey's owner doesn't match the actor's ID"
-            case publicKeyAlgo pkey of
-                Nothing ->
-                    Left $
-                    case malgo of
-                        Nothing -> "Algo not given in Sig nor actor"
-                        Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
-                Just algo ->
-                    case algo of
-                        AlgorithmEd25519 -> Right ()
-                        AlgorithmOther _ ->
-                            Left $
-                            case malgo of
-                                Nothing -> "No algo in Sig, unsupported algo in actor"
-                                Just _  -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
-            key <- case publicKey $ pemContent $ publicKeyPem pkey of
-                CryptoPassed k -> Right k
-                CryptoFailed e -> Left "Parsing Ed25519 public key failed"
             signature <- case signature sig of
                 CryptoPassed s -> Right s
                 CryptoFailed e -> Left "Parsing Ed25519 signature failed"
             if verify key input signature
-                then Right uActor
+                then Right ()
                 else Left "Ed25519 sig verification says not valid"
+        unless fromDB $ lift $ runDB $ insert_ $ VerifKey u key
+        return uActor
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of

src/Vervis/Migration.hs

@@ -187,6 +187,8 @@ changes =
     , removeEntity "RepoRoleInherit"
       -- 40
     , removeEntity "RepoRole"
+      -- 41
+    , addEntities model_2019_02_03_verifkey
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Migration/Model.hs

@@ -20,6 +20,7 @@ module Vervis.Migration.Model
     , Workflow2016Generic (..)
     , Workflow2016
     , model_2016_09_01_rest
+    , model_2019_02_03_verifkey
     )
 where
 
@@ -57,3 +58,6 @@ model_2016_09_01_rest = $(schema "2016_09_01_rest")
 
 makeEntitiesMigration "2018"
     $(modelFile "migrations/2019_01_28_project_collabs.model")
+
+model_2019_02_03_verifkey :: [Entity SqlBackend]
+model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey")

src/Vervis/Model.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -20,8 +20,10 @@ module Vervis.Model where
 import ClassyPrelude.Conduit
 import Yesod hiding (Header, parseTime)
 
+import Crypto.PubKey.Ed25519 (PublicKey)
 import Database.Persist.Quasi
 import Database.Persist.Sql (fromSqlKey)
+import Network.URI (URI)
 import Text.Email.Validate (EmailAddress)
 import Yesod.Auth.Account (PersistUserCredentials (..))