Stop using YesodHttpSig, move code from Foundation to Federation
This commit is contained in:
fr33domlover
parent
951364036f
commit
f789a773e4
3 changed files with 210 additions and 213 deletions
|
|
@ -14,11 +14,12 @@
|
|||
-}
|
||||
|
||||
module Vervis.Federation
|
||||
( handleSharerInbox
|
||||
( authenticateActivity
|
||||
, handleSharerInbox
|
||||
, handleProjectInbox
|
||||
, fixRunningDeliveries
|
||||
, handleOutboxNote
|
||||
, retryOutboxDelivery
|
||||
, authenticateActivity
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -33,6 +34,7 @@ import Control.Monad.Logger.CallStack
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Crypto.Hash
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -46,6 +48,7 @@ import Data.Semigroup
|
|||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Units
|
||||
import Data.Traversable
|
||||
import Data.Tuple
|
||||
import Database.Persist hiding (deleteBy)
|
||||
|
|
@ -53,22 +56,27 @@ import Database.Persist.Sql hiding (deleteBy)
|
|||
import Network.HTTP.Client
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.URI
|
||||
import Network.TLS
|
||||
import Network.TLS hiding (SHA256)
|
||||
import UnliftIO.Exception (try)
|
||||
import Yesod.Core hiding (logError, logWarn, logInfo)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.List as L
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.Ordered as LO
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Network.HTTP.Signature
|
||||
import Data.Time.Interval
|
||||
import Network.HTTP.Signature hiding (requestHeaders)
|
||||
import Yesod.HttpSignature
|
||||
|
||||
import Crypto.PublicVerifKey
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Network.HTTP.Digest
|
||||
import Web.ActivityPub hiding (Follow)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
|
|
@ -91,6 +99,203 @@ import Vervis.Model.Ident
|
|||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
|
||||
data ActivityDetail = ActivityDetail
|
||||
{ _actdAuthorURI :: FedURI
|
||||
, _actdInstance :: InstanceId
|
||||
, _actdAuthorId :: RemoteActorId
|
||||
, _actdRawBody :: BL.ByteString
|
||||
, _actdSignKey :: KeyId
|
||||
, _actdDigest :: Digest SHA256
|
||||
}
|
||||
|
||||
verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
|
||||
verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) = do
|
||||
(host, luKey) <- f2l <$> parseKeyId keyid
|
||||
checkHost host
|
||||
(body, digest) <- verifyBodyDigest
|
||||
mluActorHeader <- getActorHeader host
|
||||
manager <- getsYesod appHttpManager
|
||||
(inboxOrVkid, vkd) <- do
|
||||
ments <- lift $ runDB $ do
|
||||
mvk <- runMaybeT $ do
|
||||
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
|
||||
MaybeT $ getBy $ UniqueVerifKey iid luKey
|
||||
for mvk $ \ vk@(Entity _ verifkey) -> do
|
||||
mremote <- for (verifKeySharer verifkey) $ \ rsid ->
|
||||
(rsid,) <$> getJust rsid
|
||||
return (vk, mremote)
|
||||
case ments of
|
||||
Just (Entity vkid vk, mremote) -> do
|
||||
(ua, s, rsid) <-
|
||||
case mremote of
|
||||
Just (rsid, rs) -> do
|
||||
let sharer = remoteActorIdent rs
|
||||
for_ mluActorHeader $ \ u ->
|
||||
if sharer == u
|
||||
then return ()
|
||||
else throwE "Key's owner doesn't match actor header"
|
||||
return (sharer, False, rsid)
|
||||
Nothing -> do
|
||||
ua <- case mluActorHeader of
|
||||
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
|
||||
Just u -> return u
|
||||
let iid = verifKeyInstance vk
|
||||
rsid <- withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
|
||||
return (ua, True, rsid)
|
||||
return
|
||||
( Right (verifKeyInstance vk, vkid, rsid)
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = luKey
|
||||
, vkdKey = verifKeyPublic vk
|
||||
, vkdExpires = verifKeyExpires vk
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
|
||||
let verify k = ExceptT . pure $ verifySignature k input signature
|
||||
errSig1 = throwE "Fetched fresh key; Crypto sig verification says not valid"
|
||||
errSig2 = throwE "Used key from DB; Crypto sig verification says not valid; fetched fresh key; still not valid"
|
||||
errTime = throwE "Key expired"
|
||||
now <- liftIO getCurrentTime
|
||||
let stillValid Nothing = True
|
||||
stillValid (Just expires) = expires > now
|
||||
|
||||
valid1 <- verify $ vkdKey vkd
|
||||
(iid, rsid) <-
|
||||
if valid1 && stillValid (vkdExpires vkd)
|
||||
then case inboxOrVkid of
|
||||
Left uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd
|
||||
Right (iid, _vkid, rsid) -> return (iid, rsid)
|
||||
else case inboxOrVkid of
|
||||
Left _uinb ->
|
||||
if stillValid $ vkdExpires vkd
|
||||
then errSig1
|
||||
else errTime
|
||||
Right (iid, vkid, rsid) -> do
|
||||
let ua = vkdActorId vkd
|
||||
(newKey, newExp) <-
|
||||
if vkdShared vkd
|
||||
then fetchKnownSharedKey manager malgo host ua luKey
|
||||
else fetchKnownPersonalKey manager malgo host ua luKey
|
||||
if stillValid newExp
|
||||
then return ()
|
||||
else errTime
|
||||
valid2 <- verify newKey
|
||||
if valid2
|
||||
then do
|
||||
lift $ runDB $ updateVerifKey vkid vkd
|
||||
{ vkdKey = newKey
|
||||
, vkdExpires = newExp
|
||||
}
|
||||
return (iid, rsid)
|
||||
else errSig2
|
||||
|
||||
return ActivityDetail
|
||||
{ _actdAuthorURI = l2f host $ vkdActorId vkd
|
||||
, _actdInstance = iid
|
||||
, _actdAuthorId = rsid
|
||||
, _actdRawBody = body
|
||||
, _actdSignKey = KeyId keyid
|
||||
, _actdDigest = digest
|
||||
}
|
||||
where
|
||||
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
|
||||
checkHost h = do
|
||||
home <- getsYesod $ appInstanceHost . appSettings
|
||||
when (h == home) $
|
||||
throwE "Received HTTP signed request from the instance's host"
|
||||
verifyBodyDigest = do
|
||||
req <- waiRequest
|
||||
let headers = W.requestHeaders req
|
||||
digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
|
||||
Left s -> throwE $ "Parsing digest header failed: " ++ s
|
||||
Right d -> return d
|
||||
(digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req)
|
||||
unless (digest == digest') $
|
||||
throwE "Body digest verification failed"
|
||||
return (body, digest)
|
||||
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"
|
||||
fetched2vkd uk (Fetched k mexp ua uinb s) =
|
||||
( Left uinb
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = uk
|
||||
, vkdKey = k
|
||||
, vkdExpires = mexp
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
updateVerifKey vkid vkd =
|
||||
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
|
||||
withHostLock' h = ExceptT . withHostLock h . runExceptT
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-> ExceptT Text Handler (InstanceId, Object, Activity)
|
||||
authenticateActivity now = do
|
||||
verifyContentType
|
||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
|
||||
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
|
||||
let requires = [hRequestTarget, hHost, hDigest]
|
||||
wants = [hActivityPubActor]
|
||||
seconds =
|
||||
let toSeconds :: TimeInterval -> Second
|
||||
toSeconds = toTimeUnit
|
||||
in fromIntegral $ toSeconds timeLimit
|
||||
prepareToVerifyHttpSig requires wants seconds now
|
||||
ActivityDetail uSender iid _raid body _keyid _digest <-
|
||||
withExceptT T.pack $ verifyActorSig proof
|
||||
WithValue raw (Doc hActivity activity) <-
|
||||
case eitherDecode' body of
|
||||
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
||||
Right wv -> return wv
|
||||
let (hSender, luSender) = f2l uSender
|
||||
unless (hSender == hActivity) $
|
||||
throwE $ T.concat
|
||||
[ "Activity host <", hActivity
|
||||
, "> doesn't match signature key host <", hSender, ">"
|
||||
]
|
||||
unless (activityActor activity == luSender) $
|
||||
throwE $ T.concat
|
||||
[ "Activity's actor <"
|
||||
, renderFedURI $ l2f hActivity $ activityActor activity
|
||||
, "> != Signature key's actor <", renderFedURI uSender, ">"
|
||||
]
|
||||
return (iid, raw, activity)
|
||||
where
|
||||
verifyContentType = do
|
||||
ctypes <- lookupHeaders "Content-Type"
|
||||
case ctypes of
|
||||
[] -> throwE "Content-Type not specified"
|
||||
[x] | x == typeAS -> return ()
|
||||
| x == typeAS2 -> return ()
|
||||
| otherwise ->
|
||||
throwE $ "Not a recognized AP Content-Type: " <>
|
||||
case decodeUtf8' x of
|
||||
Left _ -> T.pack (show x)
|
||||
Right t -> t
|
||||
_ -> throwE "More than one Content-Type specified"
|
||||
where
|
||||
typeAS = "application/activity+json"
|
||||
typeAS2 =
|
||||
"application/ld+json; \
|
||||
\profile=\"https://www.w3.org/ns/activitystreams\""
|
||||
|
||||
hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
|
||||
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
|
||||
|
||||
|
|
@ -1312,49 +1517,3 @@ retryOutboxDelivery = do
|
|||
unless (and results) $
|
||||
logError $ "Periodic UDL delivery error for host " <> h
|
||||
return True
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-> [ByteString]
|
||||
-> ExceptT Text Handler (InstanceId, Object, Activity)
|
||||
authenticateActivity now ctypes = do
|
||||
verifyContentType
|
||||
HttpSigVerResult result <-
|
||||
ExceptT $
|
||||
first (T.pack . displayException) <$>
|
||||
verifyRequestSignature now
|
||||
ActivityDetail uSender iid _raid body _keyid _digest <- ExceptT $ pure $ first T.pack result
|
||||
WithValue raw (Doc hActivity activity) <-
|
||||
case eitherDecode' body of
|
||||
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
||||
Right wv -> return wv
|
||||
let (hSender, luSender) = f2l uSender
|
||||
unless (hSender == hActivity) $
|
||||
throwE $ T.concat
|
||||
[ "Activity host <", hActivity
|
||||
, "> doesn't match signature key host <", hSender, ">"
|
||||
]
|
||||
unless (activityActor activity == luSender) $
|
||||
throwE $ T.concat
|
||||
[ "Activity's actor <"
|
||||
, renderFedURI $ l2f hActivity $ activityActor activity
|
||||
, "> != Signature key's actor <", renderFedURI uSender, ">"
|
||||
]
|
||||
return (iid, raw, activity)
|
||||
where
|
||||
verifyContentType =
|
||||
case ctypes of
|
||||
[] -> throwE "Content-Type not specified"
|
||||
[x] | x == typeAS -> return ()
|
||||
| x == typeAS2 -> return ()
|
||||
| otherwise ->
|
||||
throwE $ "Not a recognized AP Content-Type: " <>
|
||||
case decodeUtf8' x of
|
||||
Left _ -> T.pack (show x)
|
||||
Right t -> t
|
||||
_ -> throwE "More than one Content-Type specified"
|
||||
where
|
||||
typeAS = "application/activity+json"
|
||||
typeAS2 =
|
||||
"application/ld+json; \
|
||||
\profile=\"https://www.w3.org/ns/activitystreams\""
|
||||
|
|
|
|||
|
|
@ -64,7 +64,6 @@ import Network.HTTP.Digest
|
|||
import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders)
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.Auth.Unverified.Creds
|
||||
import Yesod.HttpSignature (YesodHttpSig (..))
|
||||
import Yesod.Mail.Send
|
||||
|
||||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||
|
|
@ -657,167 +656,6 @@ instance YesodActivityPub App where
|
|||
else (renderUrl ActorKey2R, akey2)
|
||||
return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
|
||||
|
||||
data ActorDetail = ActorDetail
|
||||
{ actorDetailId :: FedURI
|
||||
, actorDetailInstance :: InstanceId
|
||||
, actorDetailSharer :: RemoteActorId
|
||||
}
|
||||
|
||||
data ActivityDetail = ActivityDetail
|
||||
{ _actdAuthorURI :: FedURI
|
||||
, _actdInstance :: InstanceId
|
||||
, _actdAuthorId :: RemoteActorId
|
||||
, _actdRawBody :: BL.ByteString
|
||||
, _actdSignKey :: KeyId
|
||||
, _actdDigest :: Digest SHA256
|
||||
}
|
||||
|
||||
instance YesodHttpSig App where
|
||||
data HttpSigVerResult App = HttpSigVerResult (Either String ActivityDetail)
|
||||
httpSigVerRequiredHeaders = const [hRequestTarget, hHost, hDigest]
|
||||
httpSigVerWantedHeaders = const [hActivityPubActor]
|
||||
httpSigVerSeconds =
|
||||
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
|
||||
where
|
||||
toSeconds :: TimeInterval -> Second
|
||||
toSeconds = toTimeUnit
|
||||
httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do
|
||||
(host, luKey) <- f2l <$> parseKeyId keyid
|
||||
checkHost host
|
||||
(body, digest) <- verifyBodyDigest
|
||||
mluActorHeader <- getActorHeader host
|
||||
manager <- getsYesod appHttpManager
|
||||
(inboxOrVkid, vkd) <- do
|
||||
ments <- lift $ runDB $ do
|
||||
mvk <- runMaybeT $ do
|
||||
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
|
||||
MaybeT $ getBy $ UniqueVerifKey iid luKey
|
||||
for mvk $ \ vk@(Entity _ verifkey) -> do
|
||||
mremote <- for (verifKeySharer verifkey) $ \ rsid ->
|
||||
(rsid,) <$> getJust rsid
|
||||
return (vk, mremote)
|
||||
case ments of
|
||||
Just (Entity vkid vk, mremote) -> do
|
||||
(ua, s, rsid) <-
|
||||
case mremote of
|
||||
Just (rsid, rs) -> do
|
||||
let sharer = remoteActorIdent rs
|
||||
for_ mluActorHeader $ \ u ->
|
||||
if sharer == u
|
||||
then return ()
|
||||
else throwE "Key's owner doesn't match actor header"
|
||||
return (sharer, False, rsid)
|
||||
Nothing -> do
|
||||
ua <- case mluActorHeader of
|
||||
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
|
||||
Just u -> return u
|
||||
let iid = verifKeyInstance vk
|
||||
rsid <- withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
|
||||
return (ua, True, rsid)
|
||||
return
|
||||
( Right (verifKeyInstance vk, vkid, rsid)
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = luKey
|
||||
, vkdKey = verifKeyPublic vk
|
||||
, vkdExpires = verifKeyExpires vk
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
|
||||
let verify k = ExceptT . pure $ verifySignature k input signature
|
||||
errSig1 = throwE "Fetched fresh key; Crypto sig verification says not valid"
|
||||
errSig2 = throwE "Used key from DB; Crypto sig verification says not valid; fetched fresh key; still not valid"
|
||||
errTime = throwE "Key expired"
|
||||
now <- liftIO getCurrentTime
|
||||
let stillValid Nothing = True
|
||||
stillValid (Just expires) = expires > now
|
||||
|
||||
valid1 <- verify $ vkdKey vkd
|
||||
(iid, rsid) <-
|
||||
if valid1 && stillValid (vkdExpires vkd)
|
||||
then case inboxOrVkid of
|
||||
Left uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd
|
||||
Right (iid, _vkid, rsid) -> return (iid, rsid)
|
||||
else case inboxOrVkid of
|
||||
Left _uinb ->
|
||||
if stillValid $ vkdExpires vkd
|
||||
then errSig1
|
||||
else errTime
|
||||
Right (iid, vkid, rsid) -> do
|
||||
let ua = vkdActorId vkd
|
||||
(newKey, newExp) <-
|
||||
if vkdShared vkd
|
||||
then fetchKnownSharedKey manager malgo host ua luKey
|
||||
else fetchKnownPersonalKey manager malgo host ua luKey
|
||||
if stillValid newExp
|
||||
then return ()
|
||||
else errTime
|
||||
valid2 <- verify newKey
|
||||
if valid2
|
||||
then do
|
||||
lift $ runDB $ updateVerifKey vkid vkd
|
||||
{ vkdKey = newKey
|
||||
, vkdExpires = newExp
|
||||
}
|
||||
return (iid, rsid)
|
||||
else errSig2
|
||||
|
||||
return ActivityDetail
|
||||
{ _actdAuthorURI = l2f host $ vkdActorId vkd
|
||||
, _actdInstance = iid
|
||||
, _actdAuthorId = rsid
|
||||
, _actdRawBody = body
|
||||
, _actdSignKey = KeyId keyid
|
||||
, _actdDigest = digest
|
||||
}
|
||||
where
|
||||
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
|
||||
checkHost h = do
|
||||
home <- getsYesod $ appInstanceHost . appSettings
|
||||
when (h == home) $
|
||||
throwE "Received HTTP signed request from the instance's host"
|
||||
where
|
||||
isAsciiLetter c = isAsciiLower c || isAsciiUpper c
|
||||
verifyBodyDigest = do
|
||||
req <- waiRequest
|
||||
let headers = requestHeaders req
|
||||
digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
|
||||
Left s -> throwE $ "Parsing digest header failed: " ++ s
|
||||
Right d -> return d
|
||||
(digest', body) <- liftIO $ hashHttpBody SHA256 (requestBody req)
|
||||
unless (digest == digest') $
|
||||
throwE "Body digest verification failed"
|
||||
return (body, digest)
|
||||
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"
|
||||
fetched2vkd uk (Fetched k mexp ua uinb s) =
|
||||
( Left uinb
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = uk
|
||||
, vkdKey = k
|
||||
, vkdExpires = mexp
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
updateVerifKey vkid vkd =
|
||||
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
|
||||
withHostLock' h = ExceptT . withHostLock h . runExceptT
|
||||
|
||||
instance YesodBreadcrumbs App where
|
||||
breadcrumb route = return $ case route of
|
||||
StaticR _ -> ("", Nothing)
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ postSharerInboxR shrRecip = do
|
|||
contentTypes <- lookupHeaders "Content-Type"
|
||||
now <- liftIO getCurrentTime
|
||||
result <- runExceptT $ do
|
||||
(iid, raw, activity) <- authenticateActivity now contentTypes
|
||||
(iid, raw, activity) <- authenticateActivity now
|
||||
(raw,) <$> handleSharerInbox now shrRecip iid raw activity
|
||||
recordActivity now result contentTypes
|
||||
case result of
|
||||
|
|
|
|||
Loading…
Reference in a new issue