Make the verification key update logic clearer
This commit is contained in:
fr33domlover
parent
9e0314fa09
commit
bf56ebf158
1 changed files with 139 additions and 67 deletions
|
|
@ -21,7 +21,7 @@ import Control.Monad.Logger.CallStack (logWarn)
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Crypto.Error (CryptoFailable (..))
|
||||
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
||||
import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify)
|
||||
import Data.Either (isRight)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.PEM (pemContent)
|
||||
|
|
@ -59,7 +59,7 @@ import Yesod.Mail.Send
|
|||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
import Web.ActivityPub hiding (PublicKey)
|
||||
|
||||
import Text.Email.Local
|
||||
import Text.Jasmine.Local (discardm)
|
||||
|
|
@ -564,6 +564,100 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
|||
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
|
||||
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
|
||||
|
||||
data AddVerifKey = AddVerifKey
|
||||
{ addvkHost :: Text
|
||||
, addvkKeyId :: FedURI
|
||||
, addvkExpires :: Maybe UTCTime
|
||||
, addvkKey :: PublicKey
|
||||
}
|
||||
|
||||
addSharedKey :: AddVerifKey -> AppDB (Maybe String)
|
||||
addSharedKey (AddVerifKey host uKey mexpires key) = do
|
||||
(iid, new) <- idAndNew <$> insertBy (Instance host)
|
||||
room <-
|
||||
if new
|
||||
then pure True
|
||||
else
|
||||
(< 2) <$>
|
||||
count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
|
||||
if room
|
||||
then do
|
||||
insert_ $ VerifKey uKey iid mexpires key Nothing
|
||||
return Nothing
|
||||
else return $ Just "We already store 2 keys"
|
||||
where
|
||||
idAndNew (Left (Entity iid _)) = (iid, False)
|
||||
idAndNew (Right iid) = (iid, True)
|
||||
|
||||
data AddPersonalKey = AddPersonalKey
|
||||
{ addpkKey :: AddVerifKey
|
||||
, addpkActorId :: FedURI
|
||||
, addpkActorInbox :: FedURI
|
||||
}
|
||||
|
||||
addPersonalKey :: AddPersonalKey -> AppDB (Maybe String)
|
||||
addPersonalKey (AddPersonalKey avk uActor uInbox) = do
|
||||
let AddVerifKey host uKey mexpires key = avk
|
||||
(iid, rsid, new) <- do
|
||||
mrs <- getBy $ UniqueRemoteSharer uActor
|
||||
case mrs of
|
||||
Nothing -> do
|
||||
iid <- either entityKey id <$> insertBy (Instance host)
|
||||
rsid <- insert $ RemoteSharer uActor iid uInbox
|
||||
return (iid, rsid, True)
|
||||
Just (Entity rsid rs) ->
|
||||
return (remoteSharerInstance rs, rsid, False)
|
||||
room <-
|
||||
if new
|
||||
then pure True
|
||||
else (< 2) <$> count [VerifKeySharer ==. Just rsid]
|
||||
if room
|
||||
then do
|
||||
insert_ $ VerifKey uKey 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 AddPersonalKey
|
||||
| VKUUpdateKey UpdateVerifKey
|
||||
|
||||
updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
|
||||
updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk
|
||||
updateVerifKeyInDB (VKUAddPersonalKey apk) = addPersonalKey apk
|
||||
updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk
|
||||
|
||||
data VerifKeyDetail = VerifKeyDetail
|
||||
{ vkdKeyId :: FedURI
|
||||
, vkdInboxOrId :: Either FedURI VerifKeyId
|
||||
, vkdKey :: PublicKey
|
||||
, vkdExpires :: Maybe UTCTime
|
||||
, vkdActorId :: FedURI
|
||||
, vkdHost :: Text
|
||||
, vkdShared :: Bool
|
||||
}
|
||||
|
||||
makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate
|
||||
makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) =
|
||||
case iori of
|
||||
Left uInbox ->
|
||||
let avk = AddVerifKey host uKey mexpires key
|
||||
in if shared
|
||||
then VKUAddSharedKey avk
|
||||
else VKUAddPersonalKey $ AddPersonalKey avk uActor uInbox
|
||||
Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
|
||||
|
||||
instance YesodHttpSig App where
|
||||
data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
|
||||
httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
|
||||
|
|
@ -579,7 +673,7 @@ instance YesodHttpSig App where
|
|||
case algo of
|
||||
S.AlgorithmEd25519 -> Right ()
|
||||
S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
|
||||
u <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
|
||||
uKey <- 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 uri
|
||||
signature <- ExceptT . pure $ do
|
||||
|
|
@ -594,9 +688,10 @@ instance YesodHttpSig App where
|
|||
t <- first displayException $ decodeUtf8' b
|
||||
parseFedURI t
|
||||
_ -> throwE "Multiple ActivityPub-Actor headers"
|
||||
(inboxOrVkid, key, mexpires, uActor, host, shared) <- do
|
||||
--(inboxOrVkid, key, mexpires, uActor, host, shared) <- do
|
||||
vkd <- do
|
||||
ments <- lift $ runDB $ do
|
||||
mvk <- getBy $ UniqueVerifKey u
|
||||
mvk <- getBy $ UniqueVerifKey uKey
|
||||
for mvk $ \ vk@(Entity _ verifkey) -> do
|
||||
mremote <- traverse getJust $ verifKeySharer verifkey
|
||||
return (vk, mremote)
|
||||
|
|
@ -609,93 +704,70 @@ instance YesodHttpSig App where
|
|||
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
|
||||
( Right vkid
|
||||
, verifKeyPublic vk
|
||||
, verifKeyExpires vk
|
||||
, ua
|
||||
, furiHost uKey
|
||||
, s
|
||||
)
|
||||
Nothing -> do
|
||||
Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u
|
||||
return (Left uinb, k, mexp, ua, h, s)
|
||||
return VerifKeyDetail
|
||||
{ vkdKeyId = uKey
|
||||
, vkdInboxOrId = Right vkid
|
||||
, vkdKey = verifKeyPublic vk
|
||||
, vkdExpires = verifKeyExpires vk
|
||||
, vkdActorId = ua
|
||||
, vkdHost = furiHost uKey
|
||||
, vkdShared = s
|
||||
}
|
||||
Nothing -> fetched2vkd uKey <$> fetchKey' muActorHeader uKey
|
||||
let verify' k = verify k input signature
|
||||
errSig = throwE "Ed25519 sig verification says not valid"
|
||||
errTime = throwE "Key expired"
|
||||
existsInDB = isRight inboxOrVkid
|
||||
existsInDB = isRight $ vkdInboxOrId vkd
|
||||
now <- liftIO getCurrentTime
|
||||
let stillValid Nothing = True
|
||||
stillValid (Just expires) = expires > now
|
||||
(write, key', mexpires') <-
|
||||
if verify' key && stillValid mexpires
|
||||
then return (not existsInDB, key, mexpires)
|
||||
|
||||
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 h s <- fetchKey' muActorHeader u
|
||||
if shared == s
|
||||
Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader uKey
|
||||
if vkdShared vkd == s
|
||||
then return ()
|
||||
else throwE "Key scope changed, we reject that"
|
||||
if shared
|
||||
then if h == host
|
||||
if vkdShared vkd
|
||||
then if h == vkdHost vkd
|
||||
then return ()
|
||||
else fail "BUG! We re-fetched a key and the host changed"
|
||||
else if newActor == uActor
|
||||
else 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 (True, newKey, newExp)
|
||||
then return $ Just vkd
|
||||
{ vkdKey = newKey
|
||||
, vkdExpires = newExp
|
||||
}
|
||||
else errSig
|
||||
else if stillValid mexpires
|
||||
else if stillValid $ vkdExpires vkd
|
||||
then errSig
|
||||
else errTime
|
||||
when write $ ExceptT $ runDB $
|
||||
case inboxOrVkid of
|
||||
Left inbox ->
|
||||
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 ()
|
||||
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 <- either entityKey id <$> insertBy (Instance host)
|
||||
rsid <- insert $ RemoteSharer uActor iid inbox
|
||||
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"
|
||||
Right vkid -> do
|
||||
update vkid
|
||||
[VerifKeyExpires =. mexpires', VerifKeyPublic =. key']
|
||||
return $ Right ()
|
||||
return uActor
|
||||
|
||||
for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate
|
||||
return $ vkdActorId vkd
|
||||
where
|
||||
fetchKey' mua uk = do
|
||||
manager <- getsYesod appHttpManager
|
||||
ExceptT $ fetchKey manager (isJust malgo) mua uk
|
||||
fetched2vkd uk (Fetched k mexp ua uinb h s) = VerifKeyDetail
|
||||
{ vkdKeyId = uk
|
||||
, vkdInboxOrId = Left uinb
|
||||
, vkdKey = k
|
||||
, vkdExpires = mexp
|
||||
, vkdActorId = ua
|
||||
, vkdHost = h
|
||||
, vkdShared = s
|
||||
}
|
||||
|
||||
instance YesodBreadcrumbs App where
|
||||
breadcrumb route = return $ case route of
|
||||
|
|
|
|||
Loading…
Reference in a new issue