mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-28 07:34:53 +09:00
Support for instance-scope keys when verifying HTTP signature
This commit is contained in:
parent
400245cf34
commit
8166d5b5eb
5 changed files with 178 additions and 70 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ""
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
Loading…
Reference in a new issue