forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Support for instance-scope keys when verifying HTTP signature

Browse source
This commit is contained in:
fr33domlover 2019-02-06 02:48:23 +00:00
parent 400245cf34
commit 8166d5b5eb
5 changed files with 178 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
config/models
View file

@ -40,18 +40,25 @@ Person
UniquePersonEmail email
VerifKey
ident URI
expires UTCTime Maybe
public PublicKey
sharer RemoteSharerId
ident URI
instance InstanceId
expires UTCTime Maybe
public PublicKey
sharer RemoteSharerId Maybe
UniqueVerifKey ident
RemoteSharer
ident URI
ident URI
instance InstanceId
UniqueRemoteSharer ident
Instance
host Text
UniqueInstance host
SshKey
ident KyIdent
person PersonId

17
migrations/2019_02_03_verifkey.model
View file

@ -1,12 +1,19 @@
VerifKey
ident String
expires UTCTime Maybe
public ByteString
sharer RemoteSharerId
ident String
instance InstanceId
expires UTCTime Maybe
public ByteString
sharer RemoteSharerId Maybe
UniqueVerifKey ident
RemoteSharer
ident String
ident String
instance InstanceId
UniqueRemoteSharer ident
Instance
host Text
UniqueInstance host

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

@ -18,6 +18,7 @@ module Data.Aeson.Local
, toEither
, fromEither
, frg
, parseHttpsURI'
, parseHttpsURI
, renderURI
, (.=?)
@ -29,7 +30,6 @@ import Prelude
import Control.Applicative ((<|>))
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Maybe (isJust)
import Data.Text (Text)
import Network.URI
@ -56,16 +56,22 @@ fromEither (Right y) = Right' y
frg :: Text
frg = "https://forgefed.angeley.es/ns#"
parseHttpsURI :: Text -> Parser URI
parseHttpsURI t =
parseHttpsURI' :: Text -> Either String URI
parseHttpsURI' t =
case parseURI $ T.unpack t of
Nothing -> fail "Invalid absolute URI"
Nothing -> Left "Invalid absolute URI"
Just u ->
if uriScheme u == "https:"
then if isJust $ uriAuthority u
then return u
else fail "URI has empty authority"
else fail "URI scheme isn't https"
then case uriAuthority u of
Just a ->
if uriUserInfo a == "" && uriPort a == ""
then Right u
else Left "URI has userinfo or port"
Nothing -> Left "URI has empty authority"
else Left "URI scheme isn't https"
parseHttpsURI :: Text -> Parser URI
parseHttpsURI = either fail return . parseHttpsURI'
renderURI :: URI -> String
renderURI u = uriToString id u ""

104
src/Vervis/Foundation.hs
View file

@ -22,7 +22,9 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
import Data.Maybe (fromJust)
import Data.PEM (pemContent)
import Data.Text.Encoding (decodeUtf8')
import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit)
import Data.Time.Units (Second, Minute, Day)
import Database.Persist.Sql (ConnectionPool, runSqlPool)
@ -30,7 +32,7 @@ import Graphics.SVGFonts.ReadFont (PreparedFont)
import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody)
import Network.HTTP.Simple (httpJSONEither, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hHost)
import Network.URI (URI (uriFragment), parseURI)
import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI)
import Text.Shakespeare.Text (textFile)
import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym)
@ -57,6 +59,7 @@ import qualified Network.HTTP.Signature as S (Algorithm (..))
import Web.ActivityPub
import Data.Aeson.Local (parseHttpsURI')
import Text.Email.Local
import Text.Jasmine.Local (discardm)
@ -560,7 +563,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
instance YesodHttpSig App where
data HttpSigVerResult App = HttpSigVerResult (Either String URI)
httpSigVerHeaders = const [hRequestTarget, hHost]
httpSigVerHeaders = const [hRequestTarget, hHost, "ActivityPub-Actor"]
httpSigVerSeconds =
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
where
@ -580,23 +583,41 @@ instance YesodHttpSig App where
case signature sig of
CryptoPassed s -> Right s
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
(mvkid, key, mexpires, uActor) <- do
muActorHeader <- do
bs <- lookupHeaders "ActivityPub-Actor"
case bs of
[] -> return Nothing
[b] -> fmap Just . ExceptT . pure $ do
t <- first displayException $ decodeUtf8' b
parseHttpsURI' t
_ -> throwE "Multiple ActivityPub-Actor headers"
(mvkid, key, mexpires, uActor, host, shared) <- do
ments <- lift $ runDB $ do
mvk <- getBy $ UniqueVerifKey u
for mvk $ \ vk@(Entity _ verifkey) -> do
remote <- getJust $ verifKeySharer verifkey
return (vk, remote)
mremote <- traverse getJust $ verifKeySharer verifkey
return (vk, mremote)
case ments of
Just (Entity vkid vk, remote) ->
Just (Entity vkid vk, mremote) -> do
(ua, s) <-
case mremote of
Just remote -> return (remoteSharerIdent remote, False)
Nothing ->
case muActorHeader of
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
Just u -> return (u, True)
let uKey = verifKeyIdent vk
return
( Just vkid
, verifKeyPublic vk
, verifKeyExpires vk
, remoteSharerIdent remote
, ua
, T.pack $ uriRegName $ fromJust $ uriAuthority uKey
, s
)
Nothing -> do
(k, mexp, ua) <- fetchKey' u
return (Nothing, k, mexp, ua)
Fetched k mexp ua h s <- fetchKey' muActorHeader u
return (Nothing, k, mexp, ua, h, s)
let verify' k = verify k input signature
errSig = throwE "Ed25519 sig verification says not valid"
errTime = throwE "Key expired"
@ -609,10 +630,17 @@ instance YesodHttpSig App where
then return (not existsInDB, key, mexpires)
else if existsInDB
then do
(newKey, newExp, newActor) <- fetchKey' u
if newActor == uActor
Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u
if shared == s
then return ()
else throwE "Key owner changed, we reject that"
else throwE "Key scope changed, we reject that"
if shared
then if h == host
then return ()
else fail "BUG! We re-fetched a key and the host changed"
else if newActor == uActor
then return ()
else throwE "Key owner changed, we reject that"
if stillValid newExp
then return ()
else errTime
@ -624,29 +652,51 @@ instance YesodHttpSig App where
else errTime
when write $ ExceptT $ runDB $
case mvkid of
Nothing -> do
ment <- getBy $ UniqueRemoteSharer uActor
case ment of
Nothing -> do
rsid <- insert $ RemoteSharer uActor
insert_ $ VerifKey u mexpires' key' rsid
return $ Right ()
Just (Entity rsid rs) -> do
n <- count [VerifKeySharer ==. rsid]
if n < 2
then do
insert_ $ VerifKey u mexpires' key' rsid
Nothing ->
if shared
then do
ment <- getBy $ UniqueInstance host
case ment of
Nothing -> do
iid <- insert $ Instance host
insert_ $ VerifKey u iid mexpires' key' Nothing
return $ Right ()
else return $ Left "We already store 2 keys"
Just (Entity iid _) -> do
n <- count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
if n < 2
then do
insert_ $ VerifKey u iid mexpires' key' Nothing
return $ Right ()
else return $ Left "We already store 2 keys"
else do
ment <- getBy $ UniqueRemoteSharer uActor
case ment of
Nothing -> do
iid <- do
ment2 <- getBy $ UniqueInstance host
case ment2 of
Nothing -> insert $ Instance host
Just (Entity i _) -> return i
rsid <- insert $ RemoteSharer uActor iid
insert_ $ VerifKey u iid mexpires' key' (Just rsid)
return $ Right ()
Just (Entity rsid rs) -> do
n <- count [VerifKeySharer ==. Just rsid]
if n < 2
then do
let iid = remoteSharerInstance rs
insert_ $ VerifKey u iid mexpires' key' (Just rsid)
return $ Right ()
else return $ Left "We already store 2 keys"
Just vkid -> do
update vkid
[VerifKeyExpires =. mexpires', VerifKeyPublic =. key']
return $ Right ()
return uActor
where
fetchKey' u = do
fetchKey' mua uk = do
manager <- getsYesod appHttpManager
ExceptT $ fetchKey manager (isJust malgo) u
ExceptT $ fetchKey manager (isJust malgo) mua uk
instance YesodBreadcrumbs App where
breadcrumb route = return $ case route of

88
src/Web/ActivityPub.hs
View file

@ -36,6 +36,7 @@ module Web.ActivityPub
, APGetError (..)
, httpGetAP
, httpPostAP
, Fetched (..)
, fetchKey
)
where
@ -72,7 +73,7 @@ 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.Text as T (pack, unpack)
import qualified Data.Vector as V (fromList, toList)
import Data.Aeson.Local
@ -361,57 +362,88 @@ httpPostAP manager uri headers sign value =
where
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
-- | Result of GETing the keyId URI and processing the JSON document.
data Fetched = Fetched
{ fetchedPublicKey :: E.PublicKey
-- ^ The Ed25519 public key corresponding to the URI we requested.
, fetchedKeyExpires :: Maybe UTCTime
-- ^ Optional expiration time declared for the key we received.
, fetchedActorId :: URI
-- ^ The @id URI of the actor for whom the key's signature applies.
, fetchedHost :: Text
-- ^ The domain name of the instance from which we got the key.
, fetchedKeyShared :: Bool
-- ^ Whether the key we received is shared. A shared key can sign
-- requests for any actor on the same instance, while a personal key is
-- only for one actor. Knowing whether the key is shared will allow us
-- when receiving more requests, whether to accept signatures made on
-- different actors, or allow only a single permanent actor for the key
-- we received.
}
fetchKey
:: MonadIO m
=> Manager
-> Bool
-> Maybe URI
-> URI
-> m (Either String (E.PublicKey, Maybe UTCTime, URI))
fetchKey manager sigAlgo u = runExceptT $ do
-> m (Either String Fetched)
fetchKey manager sigAlgo muActor uKey = 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, separate) <-
obj <- fetch uKey
let inztance = uKey { uriPath = "", uriQuery = "", uriFragment = "" }
authority =
case uriAuthority uKey of
Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!"
Just a -> a
(actor, pkey, shared) <-
case obj of
Left' pkey -> do
if publicKeyId pkey == u
if publicKeyId pkey == uKey
then return ()
else throwE "Public key's ID doesn't match the keyid URI"
let authority =
case uriAuthority u of
Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!"
Just a -> a
if uriAuthority (publicKeyOwner pkey) == Just authority
then return ()
else throwE "Actor and key on different domains, we reject"
actor <- fetch $ publicKeyOwner pkey
uActor <-
if publicKeyShared pkey
then case muActor of
Nothing -> throwE "Key is shared but actor header not specified!"
Just u -> return u
else return $ publicKeyOwner pkey
actor <- fetch uActor
let PublicKeySet k1 mk2 = actorPublicKeys actor
match (Left uri) = uri == u
match (Left uri) = uri == uKey
match (Right _) = False
if match k1 || maybe False match mk2
then return (actor, pkey, True)
then return (actor, pkey, publicKeyShared pkey)
else throwE "Actor publicKey has no URI matching pkey @id"
Right' actor -> do
if actorId actor == u { uriFragment = "" }
if actorId actor == uKey { uriFragment = "" }
then return ()
else throwE "Actor ID doesn't match the keyid URI we fetched"
case muActor of
Nothing -> return ()
Just u ->
if actorId actor == u
then return ()
else throwE "Key's owner doesn't match actor header"
let PublicKeySet k1 mk2 = actorPublicKeys actor
match (Left _) = Nothing
match (Right pk) =
if publicKeyId pk == u
if publicKeyId pk == uKey
then Just pk
else Nothing
case match k1 <|> (match =<< mk2) of
Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
Just pk -> return (actor, pk, False)
Just pk ->
if publicKeyShared pk
then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
else return (actor, pk, False)
ExceptT . pure $ do
if publicKeyShared pkey
then do
if separate
then Right ()
else Left "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
let inztance = u { uriPath = "", uriQuery = "", uriFragment = "" }
if publicKeyOwner pkey == inztance
if shared
then if publicKeyOwner pkey == inztance
then Right ()
else Left "Key is shared but its owner isn't the top-level instance URI"
else if publicKeyOwner pkey == actorId actor
@ -432,5 +464,11 @@ fetchKey manager sigAlgo u = runExceptT $ do
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, publicKeyExpires pkey, actorId actor)
CryptoFailed e -> Left "Parsing Ed25519 public key failed"
CryptoPassed k -> Right Fetched
{ fetchedPublicKey = k
, fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = actorId actor
, fetchedHost = T.pack $ uriRegName authority
, fetchedKeyShared = shared
}
CryptoFailed _ -> Left "Parsing Ed25519 public key failed"