Allow actor public key to be in a separate document

This commit is contained in:
fr33domlover 2019-02-03 23:39:56 +00:00
parent 8db38c087f
commit c336d56036
5 changed files with 88 additions and 43 deletions

View file

@ -41,6 +41,7 @@ Person
VerifKey VerifKey
ident URI ident URI
actor URI
public PublicKey public PublicKey
UniqueVerifKey ident UniqueVerifKey ident

View file

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

View file

@ -14,7 +14,8 @@
-} -}
module Data.Aeson.Local module Data.Aeson.Local
( frg ( Either' (..)
, frg
, parseHttpsURI , parseHttpsURI
, renderURI , renderURI
, (.=?) , (.=?)
@ -23,6 +24,7 @@ where
import Prelude import Prelude
import Control.Applicative ((<|>))
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
import Data.Text (Text) import Data.Text (Text)
@ -30,6 +32,11 @@ import Network.URI
import qualified Data.Text as T (unpack) import qualified Data.Text as T (unpack)
data Either' a b = Left' a | Right' b
instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where
parseJSON v = Left' <$> parseJSON v <|> Right' <$> parseJSON v
frg :: Text frg :: Text
frg = "https://forgefed.angeley.es/ns#" frg = "https://forgefed.angeley.es/ns#"

View file

@ -580,12 +580,14 @@ instance YesodHttpSig App where
case signature sig of 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"
let uActor = u { uriFragment = "" } (mvkid, key, uActor) <- do
(mvkid, key) <- do
ment <- lift $ runDB $ getBy $ UniqueVerifKey u ment <- lift $ runDB $ getBy $ UniqueVerifKey u
case ment of case ment of
Just (Entity vkid vk) -> return (Just vkid, verifKeyPublic vk) Just (Entity vkid vk) ->
Nothing -> (,) Nothing <$> fetchKey u uActor return (Just vkid, verifKeyPublic vk, verifKeyActor vk)
Nothing -> do
(k, ua) <- fetchKey' u
return (Nothing, k, ua)
let verify' k = verify k input signature let verify' k = verify k input signature
err = throwE "Ed25519 sig verification says not valid" err = throwE "Ed25519 sig verification says not valid"
existsInDB = isJust mvkid existsInDB = isJust mvkid
@ -594,51 +596,23 @@ instance YesodHttpSig App where
then return (not existsInDB, key) then return (not existsInDB, key)
else if existsInDB else if existsInDB
then do then do
newKey <- fetchKey u uActor (newKey, newActor) <- fetchKey' u
if newActor == uActor
then return ()
else throwE "Key owner changed, we reject that"
if verify' newKey if verify' newKey
then return (True, newKey) then return (True, newKey)
else err else err
else err else err
when write $ lift $ runDB $ when write $ lift $ runDB $
case mvkid of case mvkid of
Nothing -> insert_ $ VerifKey u key' Nothing -> insert_ $ VerifKey u uActor key'
Just vkid -> update vkid [VerifKeyPublic =. key'] Just vkid -> update vkid [VerifKeyPublic =. key']
return uActor return uActor
where where
fetchKey u uActor = do fetchKey' u = do
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u ExceptT $ fetchKey manager (isJust malgo) 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 k
CryptoFailed e -> Left "Parsing Ed25519 public key failed"
instance YesodBreadcrumbs App where instance YesodBreadcrumbs App where
breadcrumb route = return $ case route of breadcrumb route = return $ case route of

View file

@ -35,17 +35,21 @@ module Web.ActivityPub
, APGetError (..) , APGetError (..)
, httpGetAP , httpGetAP
, httpPostAP , httpPostAP
, fetchKey
) )
where where
import Prelude import Prelude
import Control.Applicative ((<|>)) import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, try) import Control.Exception (Exception, displayException, try)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (Writer) import Control.Monad.Trans.Writer (Writer)
import Crypto.Error (CryptoFailable (..))
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.PEM import Data.PEM
@ -62,6 +66,7 @@ import Network.URI
import Yesod.Core.Content (ContentType) import Yesod.Core.Content (ContentType)
import Yesod.Core.Handler (ProvidedRep, provideRepType) import Yesod.Core.Handler (ProvidedRep, provideRepType)
import qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey)
import qualified Data.HashMap.Strict as M (lookup) import qualified Data.HashMap.Strict as M (lookup)
import qualified Data.Text as T (unpack) import qualified Data.Text as T (unpack)
import qualified Data.Vector as V (fromList) import qualified Data.Vector as V (fromList)
@ -116,7 +121,14 @@ data PublicKey = PublicKey
} }
instance FromJSON PublicKey where instance FromJSON PublicKey where
parseJSON = withObject "PublicKey" $ \ o -> parseJSON = withObject "PublicKey" $ \ o -> do
mtyp <- optional $ o .: "@type" <|> o .: "type"
case mtyp of
Nothing -> return ()
Just t ->
if t == ("Key" :: Text)
then return ()
else fail "PublicKey @type isn't Key"
PublicKey PublicKey
<$> (parseHttpsURI =<< o .: "id") <$> (parseHttpsURI =<< o .: "id")
<*> (parseHttpsURI =<< o .: "owner") <*> (parseHttpsURI =<< o .: "owner")
@ -314,3 +326,53 @@ httpPostAP manager uri headers sign value =
httpNoBody req'' manager httpNoBody req'' manager
where where
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
fetchKey
:: MonadIO m
=> Manager
-> Bool
-> URI
-> m (Either String (E.PublicKey, URI))
fetchKey manager sigAlgo u = runExceptT $ do
let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
obj <- fetch u
(actor, pkey) <-
case obj of
Left' pkey ->
if uriAuthority (publicKeyOwner pkey) == uriAuthority u
then do
actor <- fetch $ publicKeyOwner pkey
return (actor, pkey)
else throwE "Actor and key on different domains, we reject"
Right' actor ->
if actorId actor == u { uriFragment = "" }
then return (actor, actorPublicKey actor)
else throwE "Actor ID doesn't match the keyid URI we fetched"
ExceptT . pure $ do
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 $
if sigAlgo
then "Algo mismatch, Ed25519 in Sig but none in actor"
else "Algo not given in Sig nor actor"
Just algo ->
case algo of
AlgorithmEd25519 -> Right ()
AlgorithmOther _ ->
Left $
if sigAlgo
then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
else "No algo in Sig, unsupported algo in actor"
case E.publicKey $ pemContent $ publicKeyPem pkey of
CryptoPassed k -> Right (k, actorId actor)
CryptoFailed e -> Left "Parsing Ed25519 public key failed"