Refactor the types used in activity authentication and handle project recipient
- The data returned from activity authentication has nicer types now, and no mess of big tuples. - Activity authentication code has its own module now, Vervis.Federation.Auth. - The sharer inbox handler can now handle and store activities by a local project actor, forwarded from a remote actor. This isn't in use right now, but once projects start publishing Accept activities, or other things, it may be needed.
This commit is contained in:
fr33domlover
parent
e1ae75b50c
commit
4d5fa0551f
6 changed files with 540 additions and 355 deletions
|
|
@ -14,9 +14,7 @@
|
|||
-}
|
||||
|
||||
module Vervis.Federation
|
||||
( ActivityDetail (..)
|
||||
, authenticateActivity
|
||||
, handleSharerInbox
|
||||
( handleSharerInbox
|
||||
, handleProjectInbox
|
||||
, fixRunningDeliveries
|
||||
, retryOutboxDelivery
|
||||
|
|
@ -95,6 +93,7 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Ticket
|
||||
import Vervis.Foundation
|
||||
|
|
@ -103,286 +102,6 @@ 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
|
||||
}
|
||||
|
||||
parseKeyId (KeyId k) =
|
||||
case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of
|
||||
Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
|
||||
Right u -> return u
|
||||
|
||||
verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
|
||||
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 (mname, uinb) -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host mname uinb vkd
|
||||
Right (iid, _vkid, rsid) -> return (iid, rsid)
|
||||
else case inboxOrVkid of
|
||||
Left _ ->
|
||||
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
|
||||
-- , actdDigest = digest
|
||||
}
|
||||
where
|
||||
fetched2vkd uk (Fetched k mexp ua mname uinb s) =
|
||||
( Left (mname, 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
|
||||
|
||||
verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
|
||||
verifyActorSig (Verification malgo keyid input signature) = do
|
||||
(host, luKey) <- parseKeyId keyid
|
||||
checkHost host
|
||||
mluActorHeader <- getActorHeader host
|
||||
verifyActorSig' malgo input signature host luKey mluActorHeader
|
||||
where
|
||||
checkHost h = do
|
||||
home <- getsYesod $ appInstanceHost . appSettings
|
||||
when (h == home) $
|
||||
throwE "Received HTTP signed request from the instance's host"
|
||||
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"
|
||||
|
||||
verifySelfSig :: LocalURI -> LocalURI -> ByteString -> Signature -> ExceptT String Handler PersonId
|
||||
verifySelfSig luAuthor luKey input (Signature sig) = do
|
||||
shrAuthor <- do
|
||||
route <-
|
||||
case decodeRouteLocal luAuthor of
|
||||
Nothing -> throwE "Local author ID isn't a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
SharerR shr -> return shr
|
||||
_ -> throwE "Local author ID isn't a user route"
|
||||
akey <- do
|
||||
route <-
|
||||
case decodeRouteLocal luKey of
|
||||
Nothing -> throwE "Local key ID isn't a valid route"
|
||||
Just r -> return r
|
||||
(akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
|
||||
case route of
|
||||
ActorKey1R -> return akey1
|
||||
ActorKey2R -> return akey2
|
||||
_ -> throwE "Local key ID isn't an actor key route"
|
||||
valid <-
|
||||
ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
|
||||
unless valid $
|
||||
throwE "Self sig verification says not valid"
|
||||
ExceptT $ runDB $ do
|
||||
mpid <- runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shrAuthor
|
||||
MaybeT $ getKeyBy $ UniquePersonIdent sid
|
||||
return $
|
||||
case mpid of
|
||||
Nothing -> Left "Local author: No such user"
|
||||
Just pid -> Right pid
|
||||
|
||||
verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler (Either PersonId ActivityDetail)
|
||||
verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
|
||||
(hKey, luKey) <- parseKeyId keyid
|
||||
unless (hAuthor == hKey) $
|
||||
throwE "Author and forwarded sig key on different hosts"
|
||||
local <- hostIsLocal hKey
|
||||
if local
|
||||
then Left <$> verifySelfSig luAuthor luKey input signature
|
||||
else Right <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
|
||||
authenticateActivity now = do
|
||||
(ad, wv, body) <- 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
|
||||
(detail, body) <-
|
||||
withExceptT T.pack $
|
||||
(,) <$> verifyActorSig proof
|
||||
<*> verifyBodyDigest
|
||||
wvdoc <-
|
||||
case eitherDecode' body of
|
||||
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
||||
Right wv -> return wv
|
||||
return (detail, wvdoc, body)
|
||||
let WithValue raw (Doc hActivity activity) = wv
|
||||
uSender = actdAuthorURI ad
|
||||
(hSender, luSender) = f2l uSender
|
||||
id_ <-
|
||||
if hSender == hActivity
|
||||
then do
|
||||
unless (activityActor activity == luSender) $
|
||||
throwE $ T.concat
|
||||
[ "Activity's actor <"
|
||||
, renderFedURI $ l2f hActivity $ activityActor activity
|
||||
, "> != Signature key's actor <", renderFedURI uSender
|
||||
, ">"
|
||||
]
|
||||
return $ Right ad
|
||||
else do
|
||||
mi <- checkForward uSender hActivity (activityActor activity)
|
||||
case mi of
|
||||
Nothing -> throwE $ T.concat
|
||||
[ "Activity host <", hActivity
|
||||
, "> doesn't match signature key host <", hSender, ">"
|
||||
]
|
||||
Just i -> return i
|
||||
return (id_, body, 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\""
|
||||
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
|
||||
checkForward uSender hAuthor luAuthor = do
|
||||
let hSig = hForwardedSignature
|
||||
msig <- lookupHeader hSig
|
||||
for msig $ \ _ -> do
|
||||
uForwarder <- parseForwarderHeader
|
||||
unless (uForwarder == uSender) $
|
||||
throwE "Signed forwarder doesn't match the sender"
|
||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
||||
let requires = [hDigest, hActivityPubForwarder]
|
||||
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
||||
withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
|
||||
where
|
||||
parseForwarderHeader = do
|
||||
fwds <- lookupHeaders hActivityPubForwarder
|
||||
fwd <-
|
||||
case fwds of
|
||||
[] -> throwE "ActivityPub-Forwarder header missing"
|
||||
[x] -> return x
|
||||
_ -> throwE "Multiple ActivityPub-Forwarder"
|
||||
case parseFedURI =<< (first displayException . decodeUtf8') fwd of
|
||||
Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
|
||||
Right u -> return u
|
||||
|
||||
prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
|
||||
prependError t a = do
|
||||
r <- lift $ runExceptT a
|
||||
|
|
@ -405,14 +124,13 @@ parseTicket project luContext = do
|
|||
handleSharerInbox
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> Either PersonId InstanceId
|
||||
-> Object
|
||||
-> Activity
|
||||
-> ActivityAuthentication
|
||||
-> ActivityBody
|
||||
-> ExceptT Text Handler Text
|
||||
handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
|
||||
handleSharerInbox _now shrRecip (ActivityAuthLocalPerson pidAuthor) body = do
|
||||
(shrActivity, obiid) <- do
|
||||
route <-
|
||||
case decodeRouteLocal $ activityId activity of
|
||||
case decodeRouteLocal $ activityId $ actbActivity body of
|
||||
Nothing -> throwE "Local activity: Not a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
|
|
@ -449,30 +167,76 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
|
|||
"Activity already exists in inbox of /s/" <> recip
|
||||
Just _ ->
|
||||
return $ "Activity inserted to inbox of /s/" <> recip
|
||||
handleSharerInbox now shrRecip (Right iidAuthor) raw activity =
|
||||
case activitySpecific activity of
|
||||
handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
|
||||
(shrActivity, prjActivity, obiid) <- do
|
||||
route <-
|
||||
case decodeRouteLocal $ activityId $ actbActivity body of
|
||||
Nothing -> throwE "Local activity: Not a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
ProjectOutboxItemR shr prj obikhid ->
|
||||
(shr,prj,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
|
||||
_ -> throwE "Local activity: Not an activity route"
|
||||
runDBExcept $ do
|
||||
Entity pidRecip personRecip <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getBy404 $ UniquePersonIdent sid
|
||||
mobi <- lift $ get obiid
|
||||
obi <- fromMaybeE mobi "Local activity: No such ID in DB"
|
||||
mjidOutbox <-
|
||||
lift $ getKeyBy $ UniqueProjectOutbox $ outboxItemOutbox obi
|
||||
jidOutbox <-
|
||||
fromMaybeE mjidOutbox "Local activity not in a project outbox"
|
||||
j <- lift $ getJust jidOutbox
|
||||
s <- lift $ getJust $ projectSharer j
|
||||
unless (sharerIdent s == shrActivity) $
|
||||
throwE "Local activity: ID invalid, hashid and author shr mismatch"
|
||||
unless (projectIdent j == prjActivity) $
|
||||
throwE "Local activity: ID invalid, hashid and author prj mismatch"
|
||||
unless (jidAuthor == jidOutbox) $
|
||||
throwE "Activity author in DB and in received JSON don't match"
|
||||
lift $ do
|
||||
ibiid <- insert $ InboxItem True
|
||||
let ibid = personInbox personRecip
|
||||
miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
|
||||
let recip = shr2text shrRecip
|
||||
case miblid of
|
||||
Nothing -> do
|
||||
delete ibiid
|
||||
return $
|
||||
"Activity already exists in inbox of /s/" <> recip
|
||||
Just _ ->
|
||||
return $ "Activity inserted to inbox of /s/" <> recip
|
||||
handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
|
||||
case activitySpecific $ actbActivity body of
|
||||
CreateActivity (Create note) ->
|
||||
sharerCreateNoteRemoteF now shrRecip iidAuthor raw activity note
|
||||
sharerCreateNoteF now shrRecip author body note
|
||||
OfferActivity offer ->
|
||||
sharerOfferTicketRemoteF
|
||||
now shrRecip iidAuthor raw (activityId activity) offer
|
||||
sharerOfferTicketF now shrRecip author body offer
|
||||
_ -> return "Unsupported activity type"
|
||||
|
||||
handleProjectInbox
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> PrjIdent
|
||||
-> InstanceId
|
||||
-> Text
|
||||
-> RemoteActorId
|
||||
-> BL.ByteString
|
||||
-> Object
|
||||
-> Activity
|
||||
-> ActivityAuthentication
|
||||
-> ActivityBody
|
||||
-> ExceptT Text Handler Text
|
||||
handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw activity =
|
||||
case activitySpecific activity of
|
||||
handleProjectInbox now shrRecip prjRecip auth body = do
|
||||
remoteAuthor <-
|
||||
case auth of
|
||||
ActivityAuthLocalPerson pid ->
|
||||
throwE $
|
||||
"Project inbox got local forwarded activity by pid#" <>
|
||||
T.pack (show $ fromSqlKey pid)
|
||||
ActivityAuthLocalProject jid ->
|
||||
throwE $
|
||||
"Project inbox got local forwarded activity by jid#" <>
|
||||
T.pack (show $ fromSqlKey jid)
|
||||
ActivityAuthRemote ra -> return ra
|
||||
case activitySpecific $ actbActivity body of
|
||||
CreateActivity (Create note) ->
|
||||
projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity (activityAudience activity) note
|
||||
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
|
||||
_ -> return "Unsupported activity type"
|
||||
|
||||
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
|
||||
|
|
|
|||
400
src/Vervis/Federation/Auth.hs
Normal file
400
src/Vervis/Federation/Auth.hs
Normal file
|
|
@ -0,0 +1,400 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Federation.Auth
|
||||
( RemoteAuthor (..)
|
||||
, ActivityAuthentication (..)
|
||||
, ActivityBody (..)
|
||||
, authenticateActivity
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception hiding (Handler, try)
|
||||
import Control.Monad
|
||||
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.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
||||
import Data.Maybe
|
||||
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)
|
||||
import Database.Persist.Sql hiding (deleteBy)
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.URI
|
||||
import Network.TLS hiding (SHA256)
|
||||
import UnliftIO.Exception (try)
|
||||
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
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 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
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Aeson.Local
|
||||
import Data.Either.Local
|
||||
import Data.List.Local
|
||||
import Data.List.NonEmpty.Local
|
||||
import Data.Maybe.Local
|
||||
import Data.Tuple.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
|
||||
data RemoteAuthor = RemoteAuthor
|
||||
{ remoteAuthorURI :: FedURI
|
||||
, remoteAuthorInstance :: InstanceId
|
||||
, remoteAuthorId :: RemoteActorId
|
||||
}
|
||||
|
||||
data ActivityAuthentication
|
||||
= ActivityAuthLocalPerson PersonId
|
||||
| ActivityAuthLocalProject ProjectId
|
||||
| ActivityAuthRemote RemoteAuthor
|
||||
|
||||
data ActivityBody = ActivityBody
|
||||
{ actbBL :: BL.ByteString
|
||||
, actbObject :: Object
|
||||
, actbActivity :: Activity
|
||||
}
|
||||
|
||||
parseKeyId (KeyId k) =
|
||||
case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of
|
||||
Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
|
||||
Right u -> return u
|
||||
|
||||
verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
|
||||
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 (mname, uinb) -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host mname uinb vkd
|
||||
Right (iid, _vkid, rsid) -> return (iid, rsid)
|
||||
else case inboxOrVkid of
|
||||
Left _ ->
|
||||
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 RemoteAuthor
|
||||
{ remoteAuthorURI = l2f host $ vkdActorId vkd
|
||||
, remoteAuthorInstance = iid
|
||||
, remoteAuthorId = rsid
|
||||
-- , actdRawBody = body
|
||||
-- , actdSignKey = keyid
|
||||
-- , actdDigest = digest
|
||||
}
|
||||
where
|
||||
fetched2vkd uk (Fetched k mexp ua mname uinb s) =
|
||||
( Left (mname, 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
|
||||
|
||||
verifyActorSig :: Verification -> ExceptT String Handler RemoteAuthor
|
||||
verifyActorSig (Verification malgo keyid input signature) = do
|
||||
(host, luKey) <- parseKeyId keyid
|
||||
checkHost host
|
||||
mluActorHeader <- getActorHeader host
|
||||
verifyActorSig' malgo input signature host luKey mluActorHeader
|
||||
where
|
||||
checkHost h = do
|
||||
home <- getsYesod $ appInstanceHost . appSettings
|
||||
when (h == home) $
|
||||
throwE "Received HTTP signed request from the instance's host"
|
||||
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"
|
||||
|
||||
verifySelfSig :: LocalURI -> LocalURI -> ByteString -> Signature -> ExceptT String Handler (Either PersonId ProjectId)
|
||||
verifySelfSig luAuthor luKey input (Signature sig) = do
|
||||
author <- do
|
||||
route <-
|
||||
case decodeRouteLocal luAuthor of
|
||||
Nothing -> throwE "Local author ID isn't a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
SharerR shr -> return $ Left shr
|
||||
ProjectR shr prj -> return $ Right (shr, prj)
|
||||
_ -> throwE "Local author ID isn't an actor route"
|
||||
akey <- do
|
||||
route <-
|
||||
case decodeRouteLocal luKey of
|
||||
Nothing -> throwE "Local key ID isn't a valid route"
|
||||
Just r -> return r
|
||||
(akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
|
||||
case route of
|
||||
ActorKey1R -> return akey1
|
||||
ActorKey2R -> return akey2
|
||||
_ -> throwE "Local key ID isn't an actor key route"
|
||||
valid <-
|
||||
ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
|
||||
unless valid $
|
||||
throwE "Self sig verification says not valid"
|
||||
ExceptT $ runDB $ do
|
||||
mauthorId <- runMaybeT $ bitraverse getPerson getProject author
|
||||
return $
|
||||
case mauthorId of
|
||||
Nothing -> Left "Local author: No such user/project"
|
||||
Just id_ -> Right id_
|
||||
where
|
||||
getPerson shr = do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getKeyBy $ UniquePersonIdent sid
|
||||
getProject (shr, prj) = do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getKeyBy $ UniqueProject prj sid
|
||||
|
||||
verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler ActivityAuthentication
|
||||
verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
|
||||
(hKey, luKey) <- parseKeyId keyid
|
||||
unless (hAuthor == hKey) $
|
||||
throwE "Author and forwarded sig key on different hosts"
|
||||
local <- hostIsLocal hKey
|
||||
if local
|
||||
then mkauth <$> verifySelfSig luAuthor luKey input signature
|
||||
else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
|
||||
where
|
||||
mkauth (Left pid) = ActivityAuthLocalPerson pid
|
||||
mkauth (Right jid) = ActivityAuthLocalProject jid
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
|
||||
-> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
|
||||
authenticateActivity now = do
|
||||
(ra, wv, body) <- 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
|
||||
(remoteAuthor, body) <-
|
||||
withExceptT T.pack $
|
||||
(,) <$> verifyActorSig proof
|
||||
<*> verifyBodyDigest
|
||||
wvdoc <-
|
||||
case eitherDecode' body of
|
||||
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
||||
Right wv -> return wv
|
||||
return (remoteAuthor, wvdoc, body)
|
||||
let WithValue raw (Doc hActivity activity) = wv
|
||||
uSender = remoteAuthorURI ra
|
||||
(hSender, luSender) = f2l uSender
|
||||
auth <-
|
||||
if hSender == hActivity
|
||||
then do
|
||||
unless (activityActor activity == luSender) $
|
||||
throwE $ T.concat
|
||||
[ "Activity's actor <"
|
||||
, renderFedURI $ l2f hActivity $ activityActor activity
|
||||
, "> != Signature key's actor <", renderFedURI uSender
|
||||
, ">"
|
||||
]
|
||||
return $ ActivityAuthRemote ra
|
||||
else do
|
||||
-- TODO CONTINUE
|
||||
ma <- checkForward uSender hActivity (activityActor activity)
|
||||
case ma of
|
||||
Nothing -> throwE $ T.concat
|
||||
[ "Activity host <", hActivity
|
||||
, "> doesn't match signature key host <", hSender, ">"
|
||||
]
|
||||
Just a -> return a
|
||||
return (auth, ActivityBody body 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\""
|
||||
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
|
||||
checkForward uSender hAuthor luAuthor = do
|
||||
let hSig = hForwardedSignature
|
||||
msig <- lookupHeader hSig
|
||||
for msig $ \ _ -> do
|
||||
uForwarder <- parseForwarderHeader
|
||||
unless (uForwarder == uSender) $
|
||||
throwE "Signed forwarder doesn't match the sender"
|
||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
||||
let requires = [hDigest, hActivityPubForwarder]
|
||||
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
||||
withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
|
||||
where
|
||||
parseForwarderHeader = do
|
||||
fwds <- lookupHeaders hActivityPubForwarder
|
||||
fwd <-
|
||||
case fwds of
|
||||
[] -> throwE "ActivityPub-Forwarder header missing"
|
||||
[x] -> return x
|
||||
_ -> throwE "Multiple ActivityPub-Forwarder"
|
||||
case parseFedURI =<< (first displayException . decodeUtf8') fwd of
|
||||
Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
|
||||
Right u -> return u
|
||||
|
|
@ -14,7 +14,7 @@
|
|||
-}
|
||||
|
||||
module Vervis.Federation.Discussion
|
||||
( sharerCreateNoteRemoteF
|
||||
( sharerCreateNoteF
|
||||
, projectCreateNoteF
|
||||
)
|
||||
where
|
||||
|
|
@ -92,13 +92,21 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.ActivityPub
|
||||
--import Vervis.ActorKey
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
--import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
|
||||
sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ muParent muContext mpublished _ _) = do
|
||||
sharerCreateNoteF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Note
|
||||
-> ExceptT Text Handler Text
|
||||
sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do
|
||||
_luNote <- fromMaybeE mluNote "Note without note id"
|
||||
_published <- fromMaybeE mpublished "Note without 'published' field"
|
||||
uContext <- fromMaybeE muContext "Note without context"
|
||||
|
|
@ -162,9 +170,10 @@ sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ mu
|
|||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
insertToInbox ibidRecip = do
|
||||
let luActivity = activityId activity
|
||||
jsonObj = PersistJSON raw
|
||||
ract = RemoteActivity iidSender luActivity jsonObj now
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
luActivity = activityId $ actbActivity body
|
||||
jsonObj = PersistJSON $ actbObject body
|
||||
ract = RemoteActivity iidAuthor luActivity jsonObj now
|
||||
ractid <- either entityKey id <$> insertBy' ract
|
||||
ibiid <- insert $ InboxItem True
|
||||
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
||||
|
|
@ -181,7 +190,15 @@ data CreateNoteRecipColl
|
|||
| CreateNoteRecipTicketTeam
|
||||
deriving Eq
|
||||
|
||||
projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity audience (Note mluNote _ _ muParent muCtx mpub src content) = do
|
||||
projectCreateNoteF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Note
|
||||
-> ExceptT Text Handler Text
|
||||
projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
|
||||
luNote <- fromMaybeE mluNote "Note without note id"
|
||||
published <- fromMaybeE mpub "Note without 'published' field"
|
||||
uContext <- fromMaybeE muCtx "Note without context"
|
||||
|
|
@ -201,7 +218,9 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
else do
|
||||
msig <- checkForward
|
||||
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||||
let colls = findRelevantCollections hLocal num audience
|
||||
let colls =
|
||||
findRelevantCollections hLocal num $
|
||||
activityAudience $ actbActivity body
|
||||
mremotesHttp <- runDBExcept $ do
|
||||
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
|
||||
lift $ join <$> do
|
||||
|
|
@ -287,10 +306,12 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
Nothing -> return $ Right $ l2f hParent luParent
|
||||
return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
|
||||
insertToDiscussion luNote published ibid did meparent fsid = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
raidAuthor = remoteAuthorId author
|
||||
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
||||
{ remoteActivityInstance = iidSender
|
||||
, remoteActivityIdent = activityId activity
|
||||
, remoteActivityContent = PersistJSON raw
|
||||
{ remoteActivityInstance = iidAuthor
|
||||
, remoteActivityIdent = activityId $ actbActivity body
|
||||
, remoteActivityContent = PersistJSON $ actbObject body
|
||||
, remoteActivityReceived = now
|
||||
}
|
||||
mid <- insert Message
|
||||
|
|
@ -304,8 +325,8 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
, messageRoot = did
|
||||
}
|
||||
mrmid <- insertUnique RemoteMessage
|
||||
{ remoteMessageAuthor = raidSender
|
||||
, remoteMessageInstance = iidSender
|
||||
{ remoteMessageAuthor = raidAuthor
|
||||
, remoteMessageInstance = iidAuthor
|
||||
, remoteMessageIdent = luNote
|
||||
, remoteMessageRest = mid
|
||||
, remoteMessageCreate = ractid
|
||||
|
|
@ -319,12 +340,13 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
delete mid
|
||||
return Nothing
|
||||
Just _ -> do
|
||||
insertUnique_ $ RemoteFollow raidSender fsid False
|
||||
insertUnique_ $ RemoteFollow raidAuthor fsid False
|
||||
ibiid <- insert $ InboxItem False
|
||||
insert_ $ InboxItemRemote ibid ractid ibiid
|
||||
return $ Just (ractid, mid)
|
||||
updateOrphans luNote did mid = do
|
||||
let uNote = l2f hSender luNote
|
||||
let hAuthor = furiHost $ remoteAuthorURI author
|
||||
uNote = l2f hAuthor luNote
|
||||
related <- selectOrphans uNote (E.==.)
|
||||
for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
|
||||
logWarn $ T.concat
|
||||
|
|
@ -391,7 +413,7 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
-> AppDB
|
||||
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
deliverRemoteDB ractid jid sig recips = do
|
||||
let body' = BL.toStrict body
|
||||
let body' = BL.toStrict $ actbBL body
|
||||
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
|
||||
fetchedDeliv <- for recips $ \ (i, rs) ->
|
||||
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
|
||||
|
|
@ -408,8 +430,9 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
|
|||
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
-> Handler ()
|
||||
deliverRemoteHttp sig fetched = do
|
||||
let deliver h inbox = do
|
||||
forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
|
||||
let deliver h inbox =
|
||||
let sender = ProjectR shrRecip prjRecip
|
||||
in forwardActivity (l2f h inbox) sig sender (actbBL body)
|
||||
now <- liftIO getCurrentTime
|
||||
traverse_ (fork . deliverFetched deliver now) fetched
|
||||
where
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
-}
|
||||
|
||||
module Vervis.Federation.Ticket
|
||||
( sharerOfferTicketRemoteF
|
||||
( sharerOfferTicketF
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -39,38 +39,37 @@ import Database.Persist.Local
|
|||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
||||
sharerOfferTicketRemoteF
|
||||
sharerOfferTicketF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> InstanceId
|
||||
-> Object
|
||||
-> LocalURI
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Offer
|
||||
-> ExceptT Text Handler Text
|
||||
sharerOfferTicketRemoteF
|
||||
now shrRecip iidAuthor raw luOffer (Offer ticket uTarget) = do
|
||||
verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
|
||||
_published <-
|
||||
fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
|
||||
verifyNothingE (ticketName ticket) "Ticket with 'name'"
|
||||
verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||
when (ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||
unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||
let checkDep' = checkDep hProject shrProject prjProject
|
||||
deps <- traverse checkDep' $ ticketDependsOn ticket
|
||||
local <- hostIsLocal hProject
|
||||
runDBExcept $ do
|
||||
ibidRecip <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
p <- getValBy404 $ UniquePersonIdent sid
|
||||
return $ personInbox p
|
||||
when local $ checkTargetAndDeps shrProject prjProject deps
|
||||
lift $ insertToInbox ibidRecip
|
||||
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
||||
verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
|
||||
_published <-
|
||||
fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
|
||||
verifyNothingE (ticketName ticket) "Ticket with 'name'"
|
||||
verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||
when (ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||
unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||
let checkDep' = checkDep hProject shrProject prjProject
|
||||
deps <- traverse checkDep' $ ticketDependsOn ticket
|
||||
local <- hostIsLocal hProject
|
||||
runDBExcept $ do
|
||||
ibidRecip <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
p <- getValBy404 $ UniquePersonIdent sid
|
||||
return $ personInbox p
|
||||
when local $ checkTargetAndDeps shrProject prjProject deps
|
||||
lift $ insertToInbox ibidRecip
|
||||
where
|
||||
parseTarget u = do
|
||||
let (h, lu) = f2l u
|
||||
|
|
@ -112,7 +111,9 @@ sharerOfferTicketRemoteF
|
|||
unless (isJust mt) $
|
||||
throwE "Local dep: No such ticket number in DB"
|
||||
insertToInbox ibidRecip = do
|
||||
let jsonObj = PersistJSON raw
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
luOffer = activityId $ actbActivity body
|
||||
jsonObj = PersistJSON $ actbObject body
|
||||
ract = RemoteActivity iidAuthor luOffer jsonObj now
|
||||
ractid <- either entityKey id <$> insertBy' ract
|
||||
ibiid <- insert $ InboxItem True
|
||||
|
|
|
|||
|
|
@ -113,6 +113,7 @@ import Yesod.Persist.Local
|
|||
import Vervis.ActorKey
|
||||
import Vervis.API
|
||||
import Vervis.Federation
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
|
@ -256,9 +257,8 @@ postSharerInboxR shrRecip = do
|
|||
contentTypes <- lookupHeaders "Content-Type"
|
||||
now <- liftIO getCurrentTime
|
||||
result <- runExceptT $ do
|
||||
(id_, _body, raw, activity) <- authenticateActivity now
|
||||
let id' = second actdInstance id_
|
||||
(raw,) <$> handleSharerInbox now shrRecip id' raw activity
|
||||
(auth, body) <- authenticateActivity now
|
||||
(actbObject body,) <$> handleSharerInbox now shrRecip auth body
|
||||
recordActivity now result contentTypes
|
||||
case result of
|
||||
Left _ -> sendResponseStatus badRequest400 ()
|
||||
|
|
@ -285,13 +285,9 @@ postProjectInboxR shrRecip prjRecip = do
|
|||
contentTypes <- lookupHeaders "Content-Type"
|
||||
now <- liftIO getCurrentTime
|
||||
result <- runExceptT $ do
|
||||
(id_, body, raw, activity) <- authenticateActivity now
|
||||
ActivityDetail uAuthor iidAuthor raidAuthor <-
|
||||
case id_ of
|
||||
Left _pid -> throwE "Project inbox got local forwarded activity"
|
||||
Right d -> return d
|
||||
let hAuthor = furiHost uAuthor
|
||||
(raw,) <$> handleProjectInbox now shrRecip prjRecip iidAuthor hAuthor raidAuthor body raw activity
|
||||
(auth, body) <- authenticateActivity now
|
||||
(actbObject body,) <$>
|
||||
handleProjectInbox now shrRecip prjRecip auth body
|
||||
recordActivity now result contentTypes
|
||||
case result of
|
||||
Left _ -> sendResponseStatus badRequest400 ()
|
||||
|
|
|
|||
|
|
@ -126,6 +126,7 @@ library
|
|||
Vervis.Darcs
|
||||
Vervis.Discussion
|
||||
Vervis.Federation
|
||||
Vervis.Federation.Auth
|
||||
Vervis.Federation.Discussion
|
||||
Vervis.Federation.Ticket
|
||||
Vervis.Field.Key
|
||||
|
|
|
|||
Loading…
Reference in a new issue