diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 2191181..b45acf0 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -623,10 +623,10 @@ keyListedByActorShared
-> Text
-> LocalURI
-> LocalURI
- -> Handler (Either String ())
+ -> ExceptT String Handler ()
keyListedByActorShared manager iid vkid host luKey luActor = do
mresult <- do
- ments <- runDB $ do
+ ments <- lift $ runDB $ do
mrs <- getBy $ UniqueRemoteSharer iid luActor
for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$>
@@ -638,7 +638,7 @@ keyListedByActorShared manager iid vkid host luKey luActor = do
if used
then Nothing
else Just $ Just rsid
- runExceptT $ for_ mresult $ \ mrsid -> do
+ for_ mresult $ \ mrsid -> do
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
ExceptT $ runDB $ case mrsid of
Nothing -> do
@@ -655,7 +655,6 @@ keyListedByActorShared manager iid vkid host luKey luActor = do
data VerifKeyDetail = VerifKeyDetail
{ vkdKeyId :: LocalURI
- -- , vkdInboxOrId :: Either LocalURI VerifKeyId
, vkdKey :: PublicKey
, vkdExpires :: Maybe UTCTime
, vkdActorId :: LocalURI
@@ -675,6 +674,8 @@ instance YesodHttpSig App where
(host, luKey) <- f2l <$> parseKeyId keyid
signature <- parseSig sig
mluActorHeader <- getActorHeader host
+ let sigAlgo = isJust malgo
+ manager <- getsYesod appHttpManager
(inboxOrVkid, vkd) <- do
ments <- lift $ runDB $ do
mvk <- runMaybeT $ do
@@ -700,10 +701,10 @@ instance YesodHttpSig App where
Just u -> return u
manager <- getsYesod appHttpManager
let iid = verifKeyInstance vk
- ExceptT $ keyListedByActorShared manager iid vkid host luKey ua
+ keyListedByActorShared manager iid vkid host luKey ua
return (ua, True)
return
- ( Right vkid
+ ( Right (verifKeyInstance vk, vkid)
, VerifKeyDetail
{ vkdKeyId = luKey
, vkdKey = verifKeyPublic vk
@@ -712,11 +713,10 @@ instance YesodHttpSig App where
, vkdShared = s
}
)
- Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey
+ Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager sigAlgo host mluActorHeader luKey
let verify' k = verify k input signature
errSig = throwE "Ed25519 sig verification says not valid"
errTime = throwE "Key expired"
- -- existsInDB = isRight $ vkdInboxOrId vkd
now <- liftIO getCurrentTime
let stillValid Nothing = True
stillValid (Just expires) = expires > now
@@ -724,21 +724,19 @@ instance YesodHttpSig App where
if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
then case inboxOrVkid of
Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd
- Right _vkid -> return ()
+ Right _ids -> return ()
else case inboxOrVkid of
Left _uinb ->
if stillValid $ vkdExpires vkd
then errSig
else errTime
- Right vkid -> do
- Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey
- if vkdShared vkd == s
- then return ()
- else throwE "Key scope changed, we reject that"
- unless (vkdShared vkd) $
- if newActor == vkdActorId vkd
- then return ()
- else throwE "Key owner changed, we reject that"
+ Right (iid, vkid) -> do
+ let ua = vkdActorId vkd
+ listed = keyListedByActorShared manager iid vkid host luKey ua
+ (newKey, newExp) <-
+ if vkdShared vkd
+ then fetchKnownSharedKey manager listed sigAlgo host ua luKey
+ else fetchKnownPersonalKey manager sigAlgo host ua luKey
if stillValid newExp
then return ()
else errTime
@@ -775,9 +773,6 @@ instance YesodHttpSig App where
else Left "Key and actor have different hosts"
Right lu
_ -> throwE "Multiple ActivityPub-Actor headers"
- fetchKey' h mua uk = do
- manager <- getsYesod appHttpManager
- ExceptT $ fetchKey manager (isJust malgo) h mua uk
fetched2vkd uk (Fetched k mexp ua uinb s) =
( Left uinb
, VerifKeyDetail
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 5c5dce2..1421cfa 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -47,7 +47,9 @@ module Web.ActivityPub
, Fetched (..)
, fetchAPID
, keyListedByActor
- , fetchKey
+ , fetchUnknownKey
+ , fetchKnownPersonalKey
+ , fetchKnownSharedKey
)
where
@@ -485,12 +487,14 @@ data Fetched = Fetched
fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP m u
+{-
fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
fetchAPH m h lu = do
Doc h' v <- fetchAP m $ l2f h lu
if h == h'
then return v
else throwE "Object @id URI's host doesn't match the URI we fetched"
+-}
fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
fetchAPID m getId h lu = runExceptT $ do
@@ -535,15 +539,53 @@ keyListedByActor manager host luKey luActor = runExceptT $ do
match (Right _) = False
in match k1 || maybe False match mk2
-fetchKey
+matchKeyObj luKey (PublicKeySet k1 mk2) =
+ let match' = match luKey
+ in 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 pk
+ where
+ match _ (Left _) = Nothing
+ match luk (Right pk) =
+ if publicKeyId pk == luk
+ then Just pk
+ else Nothing
+
+verifyAlgo sigAlgo Nothing =
+ Left $
+ if sigAlgo
+ then "Algo mismatch, Ed25519 in Sig but none in actor"
+ else "Algo not given in Sig nor actor"
+verifyAlgo sigAlgo (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"
+
+parseKey pem =
+ case E.publicKey $ pemContent pem of
+ CryptoPassed k -> Right k
+ CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
+
+-- | Fetch a key we don't have cached locally.
+fetchUnknownKey
:: MonadIO m
=> Manager
+ -- ^ Manager for making HTTP requests
-> Bool
+ -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+ -- signature header
-> Text
+ -- ^ Instance host
-> Maybe LocalURI
+ -- ^ Actor URI possibly provided in the HTTP request's actor header
-> LocalURI
- -> m (Either String Fetched)
-fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
+ -- ^ Key URI provided in HTTP signature header
+ -> ExceptT String m Fetched
+fetchUnknownKey manager sigAlgo host mluActor luKey = do
obj <- fetchAPIDOrH manager publicKeyId host luKey
(pem, mkFetched, malgo) <-
case obj of
@@ -603,32 +645,81 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
ExceptT . pure $ do
verifyAlgo sigAlgo malgo
mkFetched <$> parseKey pem
- where
- matchKeyObj luKey (PublicKeySet k1 mk2) =
- let match' = match luKey
- in 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 pk
- where
- match _ (Left _) = Nothing
- match luk (Right pk) =
- if publicKeyId pk == luk
- then Just pk
- else Nothing
- verifyAlgo sigAlgo Nothing =
- Left $
- if sigAlgo
- then "Algo mismatch, Ed25519 in Sig but none in actor"
- else "Algo not given in Sig nor actor"
- verifyAlgo sigAlgo (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"
- parseKey pem =
- case E.publicKey $ pemContent pem of
- CryptoPassed k -> Right k
- CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
+
+keyDetail pk = (publicKeyPem pk, publicKeyExpires pk, publicKeyAlgo pk)
+
+-- | Fetch a personal key we already have cached locally, but we'd like to
+-- refresh the local copy by fetching the key again from the server.
+fetchKnownPersonalKey
+ :: MonadIO m
+ => Manager
+ -- ^ Manager for making HTTP requests
+ -> Bool
+ -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+ -- signature header
+ -> Text
+ -- ^ Instance host
+ -> LocalURI
+ -- ^ Key owner actor ID URI
+ -> LocalURI
+ -- ^ Key URI
+ -> ExceptT String m (E.PublicKey, Maybe UTCTime)
+fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
+ obj <- fetchAPIDOrH manager publicKeyId host luKey
+ (pem, mexpires, malgo) <-
+ case obj of
+ Left pkey -> do
+ case publicKeyOwner pkey of
+ OwnerInstance -> throwE "Personal key became shared"
+ OwnerActor owner ->
+ when (luOwner /= owner) $ throwE "Key owner changed"
+ return $ keyDetail pkey
+ Right actor -> do
+ when (actorId actor /= luKey { luriFragment = "" }) $
+ throwE "Actor ID doesn't match the keyid URI we fetched"
+ when (actorId actor /= luOwner) $
+ throwE "Key owner changed"
+ pk <- matchKeyObj luKey $ actorPublicKeys actor
+ case publicKeyOwner pk of
+ OwnerInstance -> throwE "Personal key became shared"
+ OwnerActor owner ->
+ when (owner /= luOwner) $
+ throwE "Actor's publicKey's owner doesn't match the actor's ID"
+ return $ keyDetail pk
+ ExceptT . pure $ do
+ verifyAlgo sigAlgo malgo
+ (, mexpires) <$> parseKey pem
+
+-- | Fetch a shared key we already have cached locally, but we'd like to
+-- refresh the local copy by fetching the key again from the server.
+fetchKnownSharedKey
+ :: MonadIO m
+ => Manager
+ -- ^ Manager for making HTTP requests
+ -> ExceptT String m ()
+ -- ^ Action which checks whether the actor from HTTP actor header lists the
+ -- key, potentually updating our local cache if needed.
+ -> Bool
+ -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+ -- signature header
+ -> Text
+ -- ^ Instance host
+ -> LocalURI
+ -- ^ Actor ID from HTTP actor header
+ -> LocalURI
+ -- ^ Key URI
+ -> ExceptT String m (E.PublicKey, Maybe UTCTime)
+fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do
+ obj <- fetchAPIDOrH manager publicKeyId host luKey
+ pkey <-
+ case obj :: Either PublicKey Actor of
+ Left pk -> return pk
+ Right _actor -> throwE "Expected stand-alone key, got embedded key"
+ case publicKeyOwner pkey of
+ OwnerInstance -> return ()
+ OwnerActor _owner -> throwE "Shared key became personal"
+ listed
+ let (pem, mexpires, malgo) = keyDetail pkey
+ ExceptT . pure $ do
+ verifyAlgo sigAlgo malgo
+ (, mexpires) <$> parseKey pem