Store remote actor keys in the DB, reuse them instead of GETing every time
This commit is contained in:
parent
21c8df1251
commit
b0b2aa83c5
8 changed files with 113 additions and 38 deletions
|
@ -39,6 +39,12 @@ Person
|
||||||
UniquePersonLogin login
|
UniquePersonLogin login
|
||||||
UniquePersonEmail email
|
UniquePersonEmail email
|
||||||
|
|
||||||
|
VerifKey
|
||||||
|
ident URI
|
||||||
|
public PublicKey
|
||||||
|
|
||||||
|
UniqueVerifKey ident
|
||||||
|
|
||||||
SshKey
|
SshKey
|
||||||
ident KyIdent
|
ident KyIdent
|
||||||
person PersonId
|
person PersonId
|
||||||
|
|
5
migrations/2019_02_03_verifkey.model
Normal file
5
migrations/2019_02_03_verifkey.model
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
VerifKey
|
||||||
|
ident String
|
||||||
|
public ByteString
|
||||||
|
|
||||||
|
UniqueVerifKey ident
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -13,7 +13,6 @@
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
-- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields.
|
|
||||||
module Database.Persist.Class.Local
|
module Database.Persist.Class.Local
|
||||||
(
|
(
|
||||||
)
|
)
|
||||||
|
@ -21,11 +20,46 @@ where
|
||||||
|
|
||||||
import Prelude
|
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 Data.CaseInsensitive (CI)
|
||||||
import Database.Persist.Class
|
import Database.Persist.Class
|
||||||
|
import Network.URI (URI, uriScheme, parseURI)
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
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
|
instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where
|
||||||
toPersistValue = toPersistValue . CI.original
|
toPersistValue = toPersistValue . CI.original
|
||||||
fromPersistValue = fmap CI.mk . fromPersistValue
|
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'
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -20,12 +20,26 @@ where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
|
import Crypto.PubKey.Ed25519 (PublicKey)
|
||||||
|
import Data.ByteArray (convert)
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
import Database.Persist.Sql
|
import Database.Persist.Sql
|
||||||
|
import Network.URI (URI)
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import Data.Aeson.Local (renderURI)
|
||||||
import Database.Persist.Class.Local ()
|
import Database.Persist.Class.Local ()
|
||||||
|
|
||||||
instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
|
instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
|
||||||
sqlType = sqlType . fmap CI.original
|
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
|
||||||
|
|
|
@ -576,46 +576,54 @@ instance YesodHttpSig App where
|
||||||
u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
|
u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
|
||||||
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
||||||
Just uri -> Right uri
|
Just uri -> Right uri
|
||||||
manager <- getsYesod appHttpManager
|
let uActor = u { uriFragment = "" }
|
||||||
actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
(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
|
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
|
signature <- case signature sig of
|
||||||
CryptoPassed s -> Right s
|
CryptoPassed s -> Right s
|
||||||
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
||||||
if verify key input signature
|
if verify key input signature
|
||||||
then Right uActor
|
then Right ()
|
||||||
else Left "Ed25519 sig verification says not valid"
|
else Left "Ed25519 sig verification says not valid"
|
||||||
|
unless fromDB $ lift $ runDB $ insert_ $ VerifKey u key
|
||||||
|
return uActor
|
||||||
|
|
||||||
instance YesodBreadcrumbs App where
|
instance YesodBreadcrumbs App where
|
||||||
breadcrumb route = return $ case route of
|
breadcrumb route = return $ case route of
|
||||||
|
|
|
@ -187,6 +187,8 @@ changes =
|
||||||
, removeEntity "RepoRoleInherit"
|
, removeEntity "RepoRoleInherit"
|
||||||
-- 40
|
-- 40
|
||||||
, removeEntity "RepoRole"
|
, removeEntity "RepoRole"
|
||||||
|
-- 41
|
||||||
|
, addEntities model_2019_02_03_verifkey
|
||||||
]
|
]
|
||||||
|
|
||||||
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
|
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
|
||||||
|
|
|
@ -20,6 +20,7 @@ module Vervis.Migration.Model
|
||||||
, Workflow2016Generic (..)
|
, Workflow2016Generic (..)
|
||||||
, Workflow2016
|
, Workflow2016
|
||||||
, model_2016_09_01_rest
|
, model_2016_09_01_rest
|
||||||
|
, model_2019_02_03_verifkey
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -57,3 +58,6 @@ model_2016_09_01_rest = $(schema "2016_09_01_rest")
|
||||||
|
|
||||||
makeEntitiesMigration "2018"
|
makeEntitiesMigration "2018"
|
||||||
$(modelFile "migrations/2019_01_28_project_collabs.model")
|
$(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")
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -20,8 +20,10 @@ module Vervis.Model where
|
||||||
import ClassyPrelude.Conduit
|
import ClassyPrelude.Conduit
|
||||||
import Yesod hiding (Header, parseTime)
|
import Yesod hiding (Header, parseTime)
|
||||||
|
|
||||||
|
import Crypto.PubKey.Ed25519 (PublicKey)
|
||||||
import Database.Persist.Quasi
|
import Database.Persist.Quasi
|
||||||
import Database.Persist.Sql (fromSqlKey)
|
import Database.Persist.Sql (fromSqlKey)
|
||||||
|
import Network.URI (URI)
|
||||||
import Text.Email.Validate (EmailAddress)
|
import Text.Email.Validate (EmailAddress)
|
||||||
import Yesod.Auth.Account (PersistUserCredentials (..))
|
import Yesod.Auth.Account (PersistUserCredentials (..))
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue