forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Allow actor public key to be in a separate document

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

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

1
migrations/2019_02_03_verifkey.model
View file

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

9
src/Data/Aeson/Local.hs
View file

@ -14,7 +14,8 @@
-}
module Data.Aeson.Local
( frg
( Either' (..)
, frg
, parseHttpsURI
, renderURI
, (.=?)
@ -23,6 +24,7 @@ where
import Prelude
import Control.Applicative ((<|>))
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Text (Text)
@ -30,6 +32,11 @@ import Network.URI
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 = "https://forgefed.angeley.es/ns#"

52
src/Vervis/Foundation.hs
View file

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

68
src/Web/ActivityPub.hs
View file

@ -35,17 +35,21 @@ module Web.ActivityPub
, APGetError (..)
, httpGetAP
, httpPostAP
, fetchKey
)
where
import Prelude
import Control.Applicative ((<|>))
import Control.Exception (Exception, try)
import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, displayException, try)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (Writer)
import Crypto.Error (CryptoFailable (..))
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Data.PEM
@ -62,6 +66,7 @@ import Network.URI
import Yesod.Core.Content (ContentType)
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.Text as T (unpack)
import qualified Data.Vector as V (fromList)
@ -116,7 +121,14 @@ data PublicKey = PublicKey
}
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
<$> (parseHttpsURI =<< o .: "id")
<*> (parseHttpsURI =<< o .: "owner")
@ -314,3 +326,53 @@ httpPostAP manager uri headers sign value =
httpNoBody req'' manager
where
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"