sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 02:54:52 +09:00
Code Issues Activity

Make the verification key update logic clearer

Browse source
This commit is contained in:
fr33domlover 2019-02-16 21:47:58 +00:00
parent 9e0314fa09
commit bf56ebf158
1 changed files with 139 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

206
src/Vervis/Foundation.hs
View file

@ -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