diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 291b2c3..2191181 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -603,7 +603,20 @@ actorRoom rsid = (count [VerifKeySharedUsageUser ==. rsid]) (count [VerifKeySharer ==. Just rsid]) -keyListedByActor' +-- | Given a shared key we have in our DB, verify that the given actor lists +-- this key, and update the DB accordingly. +-- +-- * If we know the actor and we have a record that it lists the key, return +-- success, otherwise no action +-- * If we know the actor but we don't have a record of usage, fetch the +-- actor and verify usage. If the actor already has 2 known keys, return +-- error, otherwise store usage in DB. +-- * If we don't know the actor, fetch actor, verify usage, store actor and +-- usage in DB. +-- +-- If we get success, that means the actor lists the key, and both the actor +-- and the usage exist in our DB now. +keyListedByActorShared :: Manager -> InstanceId -> VerifKeyId @@ -611,7 +624,7 @@ keyListedByActor' -> LocalURI -> LocalURI -> Handler (Either String ()) -keyListedByActor' manager iid vkid host luKey luActor = do +keyListedByActorShared manager iid vkid host luKey luActor = do mresult <- do ments <- runDB $ do mrs <- getBy $ UniqueRemoteSharer iid luActor @@ -640,92 +653,15 @@ keyListedByActor' manager iid vkid host luKey luActor = do return $ Right () else return $ Left "Actor already has at least 2 keys" -data AddVerifKey = AddVerifKey - { addvkHost :: Text - , addvkKeyId :: LocalURI - , addvkExpires :: Maybe UTCTime - , addvkKey :: PublicKey - , addvkActorId :: LocalURI - , addvkActorInbox :: LocalURI - } - -addSharedKey :: AddVerifKey -> AppDB (Maybe String) -addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do - (iid, rsid, inew) <- instanceAndActor host luActor luInbox - room <- - case inew of - Nothing -> pure True - Just rsnew -> do - iRoom <- instanceRoom iid - if iRoom - then if rsnew - then pure True - else actorRoom rsid - else return False - if room - then do - vkid <- insert $ VerifKey luKey iid mexpires key Nothing - insert_ $ VerifKeySharedUsage vkid rsid - return Nothing - else return $ Just "We already store 2 keys" - where - instanceRoom iid = - (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] - -addPersonalKey :: AddVerifKey -> AppDB (Maybe String) -addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do - (iid, rsid, inew) <- instanceAndActor host luActor luInbox - room <- - if inew == Just False - then actorRoom rsid - else pure True - if room - then do - insert_ $ VerifKey luKey iid mexpires key (Just rsid) - return Nothing - else return $ Just "We already store 2 keys" - -data UpdateVerifKey = UpdateVerifKey - { updvkId :: VerifKeyId - , updvkExpires :: Maybe UTCTime - , updvkKey :: PublicKey - } - -updateVerifKey :: UpdateVerifKey -> AppDB (Maybe String) -updateVerifKey (UpdateVerifKey vkid mexpires key) = do - update vkid [VerifKeyExpires =. mexpires, VerifKeyPublic =. key] - return Nothing - -data VerifKeyUpdate - = VKUAddSharedKey AddVerifKey - | VKUAddPersonalKey AddVerifKey - | VKUUpdateKey UpdateVerifKey - -updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String) -updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk -updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk -updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk - data VerifKeyDetail = VerifKeyDetail { vkdKeyId :: LocalURI - , vkdInboxOrId :: Either LocalURI VerifKeyId + -- , vkdInboxOrId :: Either LocalURI VerifKeyId , vkdKey :: PublicKey , vkdExpires :: Maybe UTCTime , vkdActorId :: LocalURI , vkdShared :: Bool } -makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate -makeVerifKeyUpdate - host (VerifKeyDetail luKey iori key mexpires luActor shared) = - case iori of - Left luInbox -> - let avk = AddVerifKey host luKey mexpires key luActor luInbox - in if shared - then VKUAddSharedKey avk - else VKUAddPersonalKey avk - Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key - instance YesodHttpSig App where data HttpSigVerResult App = HttpSigVerResult (Either String FedURI) httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor] @@ -735,32 +671,11 @@ instance YesodHttpSig App where toSeconds :: TimeInterval -> Second toSeconds = toTimeUnit httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do - ExceptT . pure $ case malgo of - Nothing -> Right () - Just algo -> - case algo of - S.AlgorithmEd25519 -> Right () - S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" - (host, luKey) <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of - Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e - Right uri -> Right $ f2l uri - signature <- ExceptT . pure $ do - case signature sig of - CryptoPassed s -> Right s - CryptoFailed e -> Left "Parsing Ed25519 signature failed" - mluActorHeader <- do - bs <- lookupHeaders hActivityPubActor - case bs of - [] -> return Nothing - [b] -> fmap Just . ExceptT . pure $ do - t <- first displayException $ decodeUtf8' b - (h, lu) <- f2l <$> parseFedURI t - if h == host - then Right () - else Left "Key and actor have different hosts" - Right lu - _ -> throwE "Multiple ActivityPub-Actor headers" - vkd <- do + verifySigAlgo malgo + (host, luKey) <- f2l <$> parseKeyId keyid + signature <- parseSig sig + mluActorHeader <- getActorHeader host + (inboxOrVkid, vkd) <- do ments <- lift $ runDB $ do mvk <- runMaybeT $ do Entity iid _ <- MaybeT $ getBy $ UniqueInstance host @@ -785,68 +700,133 @@ instance YesodHttpSig App where Just u -> return u manager <- getsYesod appHttpManager let iid = verifKeyInstance vk - ExceptT $ - keyListedByActor' manager iid vkid host luKey ua + ExceptT $ keyListedByActorShared manager iid vkid host luKey ua return (ua, True) - return VerifKeyDetail - { vkdKeyId = luKey - , vkdInboxOrId = Right vkid - , vkdKey = verifKeyPublic vk - , vkdExpires = verifKeyExpires vk - , vkdActorId = ua - , vkdShared = s - } + return + ( Right vkid + , VerifKeyDetail + { vkdKeyId = luKey + , vkdKey = verifKeyPublic vk + , vkdExpires = verifKeyExpires vk + , vkdActorId = ua + , vkdShared = s + } + ) Nothing -> fetched2vkd luKey <$> fetchKey' 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 + -- existsInDB = isRight $ vkdInboxOrId vkd now <- liftIO getCurrentTime let stillValid Nothing = True stillValid (Just expires) = expires > now - mvkd <- - if verify' (vkdKey vkd) && stillValid (vkdExpires vkd) - then return $ if existsInDB - then Nothing - else Just vkd - else if existsInDB - then do - Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey - if vkdShared vkd == s + if verify' (vkdKey vkd) && stillValid (vkdExpires vkd) + then case inboxOrVkid of + Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd + Right _vkid -> 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 scope changed, we reject that" - unless (vkdShared vkd) $ - if newActor == vkdActorId vkd - then return () - else throwE "Key owner changed, we reject that" - if stillValid newExp - then return () - else errTime - if verify' newKey - then return $ Just vkd - { vkdKey = newKey - , vkdExpires = newExp - } - else errSig - else if stillValid $ vkdExpires vkd - then errSig - else errTime + else throwE "Key owner changed, we reject that" + if stillValid newExp + then return () + else errTime + if verify' newKey + then lift $ runDB $ updateVerifKey vkid vkd + { vkdKey = newKey + , vkdExpires = newExp + } + else errSig - for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate host return $ l2f host $ vkdActorId vkd where + verifySigAlgo = traverse_ $ \ algo -> + case algo of + S.AlgorithmEd25519 -> return () + S.AlgorithmOther _ -> throwE "Unsupported algo in Sig header" + parseKeyId k = + case parseFedURI =<< (first displayException . decodeUtf8') k of + Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e + Right u -> return u + parseSig b = + case signature b of + CryptoPassed s -> return s + CryptoFailed e -> throwE "Parsing Ed25519 signature failed" + getActorHeader host = do + bs <- lookupHeaders hActivityPubActor + case bs of + [] -> return Nothing + [b] -> fmap Just . ExceptT . pure $ do + t <- first displayException $ decodeUtf8' b + (h, lu) <- f2l <$> parseFedURI t + if h == host + then Right () + 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) = VerifKeyDetail - { vkdKeyId = uk - , vkdInboxOrId = Left uinb - , vkdKey = k - , vkdExpires = mexp - , vkdActorId = ua - , vkdShared = s - } + fetched2vkd uk (Fetched k mexp ua uinb s) = + ( Left uinb + , VerifKeyDetail + { vkdKeyId = uk + , vkdKey = k + , vkdExpires = mexp + , vkdActorId = ua + , vkdShared = s + } + ) + addVerifKey h uinb vkd = + if vkdShared vkd + then addSharedKey h uinb vkd + else addPersonalKey h uinb vkd + where + addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do + (iid, rsid, inew) <- instanceAndActor host luActor luInbox + room <- + case inew of + Nothing -> pure True + Just rsnew -> do + iRoom <- instanceRoom iid + if iRoom + then if rsnew + then pure True + else actorRoom rsid + else return False + if room + then do + vkid <- insert $ VerifKey luKey iid mexpires key Nothing + insert_ $ VerifKeySharedUsage vkid rsid + return $ Right () + else return $ Left "We already store 2 keys" + where + instanceRoom iid = + (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] + addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do + (iid, rsid, inew) <- instanceAndActor host luActor luInbox + room <- + if inew == Just False + then actorRoom rsid + else pure True + if room + then do + insert_ $ VerifKey luKey iid mexpires key (Just rsid) + return $ Right () + else return $ Left "We already store 2 keys" + updateVerifKey vkid vkd = + update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd] instance YesodBreadcrumbs App where breadcrumb route = return $ case route of diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 5b0b4b0..7a258c5 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -545,23 +545,34 @@ fetchKey -> m (Either String Fetched) fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do obj <- fetchAPIDOrH manager publicKeyId host luKey - (actor, pkey) <- + (pem, mkFetched, malgo) <- case obj of Left pkey -> do - luActor <- + (oi, luActor) <- case publicKeyOwner pkey of OwnerInstance -> case mluActor of Nothing -> throwE "Key is shared but actor header not specified!" - Just u -> return u + Just u -> return (True, u) OwnerActor owner -> do for_ mluActor $ \ lu -> if owner == lu then return () else throwE "Key's owner doesn't match actor header" - return owner - actor <- ExceptT $ keyListedByActor manager host luKey luActor - return (actor, pkey) + return (False, owner) + inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor) + return + ( publicKeyPem pkey + , \ k -> + Fetched + { fetchedPublicKey = k + , fetchedKeyExpires = publicKeyExpires pkey + , fetchedActorId = luActor + , fetchedActorInbox = inbox + , fetchedKeyShared = oi + } + , publicKeyAlgo pkey + ) Right actor -> do if actorId actor == luKey { luriFragment = "" } then return () @@ -581,15 +592,24 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do Just pk -> case publicKeyOwner pk of OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" - OwnerActor _ -> return (actor, pk) + OwnerActor owner -> do + if owner == actorId actor + then return () + else throwE "Actor's publicKey's owner doesn't match the actor's ID" + return + ( publicKeyPem pk + , \ k -> + Fetched + { fetchedPublicKey = k + , fetchedKeyExpires = publicKeyExpires pk + , fetchedActorId = owner + , fetchedActorInbox = actorInbox actor + , fetchedKeyShared = False + } + , publicKeyAlgo pk + ) ExceptT . pure $ do - case publicKeyOwner pkey of - OwnerInstance -> Right () - OwnerActor owner -> - if owner == actorId actor - then Right () - else Left "Actor's publicKey's owner doesn't match the actor's ID" - case publicKeyAlgo pkey of + case malgo of Nothing -> Left $ if sigAlgo @@ -603,12 +623,6 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do 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 Fetched - { fetchedPublicKey = k - , fetchedKeyExpires = publicKeyExpires pkey - , fetchedActorId = actorId actor - , fetchedActorInbox = actorInbox actor - , fetchedKeyShared = ownerShared $ publicKeyOwner pkey - } + case E.publicKey $ pemContent pem of + CryptoPassed k -> Right $ mkFetched k CryptoFailed _ -> Left "Parsing Ed25519 public key failed"