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.

src/Vervis/Federation.hs

@@ -14,9 +14,7 @@
  -}
 
 module Vervis.Federation
-    ( ActivityDetail (..)
+    ( handleSharerInbox
-    , authenticateActivity
-    , 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
+    -> ActivityAuthentication
-    -> Object
+    -> ActivityBody
-    -> Activity
     -> 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 =
+handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
-    case activitySpecific activity of
+    (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
+            sharerOfferTicketF now shrRecip author body offer
-                now shrRecip iidAuthor raw (activityId activity) offer
         _ -> return "Unsupported activity type"
 
 handleProjectInbox
     :: UTCTime
     -> ShrIdent
     -> PrjIdent
-    -> InstanceId
+    -> ActivityAuthentication
-    -> Text
+    -> ActivityBody
-    -> RemoteActorId
-    -> BL.ByteString
-    -> Object
-    -> Activity
     -> ExceptT Text Handler Text
-handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw activity =
+handleProjectInbox now shrRecip prjRecip auth body = do
-    case activitySpecific activity of
+    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 ()

src/Vervis/Federation/Auth.hs

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

src/Vervis/Federation/Discussion.hs

@@ -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
+        let iidAuthor = remoteAuthorInstance author
-            jsonObj = PersistJSON raw
+            luActivity = activityId $ actbActivity body
-            ract = RemoteActivity iidSender luActivity jsonObj now
+            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
+            { remoteActivityInstance = iidAuthor
-            , remoteActivityIdent    = activityId activity
+            , remoteActivityIdent    = activityId $ actbActivity body
-            , remoteActivityContent  = PersistJSON raw
+            , 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
+            { remoteMessageAuthor     = raidAuthor
-            , remoteMessageInstance   = iidSender
+            , 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
+        let deliver h inbox =
-                forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
+                let sender = ProjectR shrRecip prjRecip
+                in  forwardActivity (l2f h inbox) sig sender (actbBL body)
         now <- liftIO getCurrentTime
         traverse_ (fork . deliverFetched deliver now) fetched
         where

src/Vervis/Federation/Ticket.hs

@@ -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
+    -> RemoteAuthor
-    -> Object
+    -> ActivityBody
-    -> LocalURI
     -> Offer
     -> ExceptT Text Handler Text
-sharerOfferTicketRemoteF
+sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
-    now shrRecip iidAuthor raw luOffer (Offer ticket uTarget) = do
+    verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
-        verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
+    _published <-
-        _published <-
+        fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
-            fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
+    verifyNothingE (ticketName ticket) "Ticket with 'name'"
-        verifyNothingE (ticketName ticket) "Ticket with 'name'"
+    verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
-        verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
+    when (ticketIsResolved ticket) $ throwE "Ticket resolved"
-        when (ticketIsResolved ticket) $ throwE "Ticket resolved"
+    (hProject, shrProject, prjProject) <- parseTarget uTarget
-        (hProject, shrProject, prjProject) <- parseTarget uTarget
+    unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
-        unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
+    let checkDep' = checkDep hProject shrProject prjProject
-        let checkDep' = checkDep hProject shrProject prjProject
+    deps <- traverse checkDep' $ ticketDependsOn ticket
-        deps <- traverse checkDep' $ ticketDependsOn ticket
+    local <- hostIsLocal hProject
-        local <- hostIsLocal hProject
+    runDBExcept $ do
-        runDBExcept $ do
+        ibidRecip <- lift $ do
-            ibidRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-                sid <- getKeyBy404 $ UniqueSharer shrRecip
+            p <- getValBy404 $ UniquePersonIdent sid
-                p <- getValBy404 $ UniquePersonIdent sid
+            return $ personInbox p
-                return $ personInbox p
+        when local $ checkTargetAndDeps shrProject prjProject deps
-            when local $ checkTargetAndDeps shrProject prjProject deps
+        lift $ insertToInbox ibidRecip
-            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

src/Vervis/Handler/Inbox.hs

@@ -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
+        (auth, body) <- authenticateActivity now
-        let id' = second actdInstance id_
+        (actbObject body,) <$> handleSharerInbox now shrRecip auth body
-        (raw,) <$> handleSharerInbox now shrRecip id' raw activity
     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
+        (auth, body) <- authenticateActivity now
-        ActivityDetail uAuthor iidAuthor raidAuthor <-
+        (actbObject body,) <$>
-            case id_ of
+            handleProjectInbox now shrRecip prjRecip auth body
-                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
     recordActivity now result contentTypes
     case result of
         Left _ -> sendResponseStatus badRequest400 ()

vervis.cabal

@@ -126,6 +126,7 @@ library
                        Vervis.Darcs
                        Vervis.Discussion
                        Vervis.Federation
+                       Vervis.Federation.Auth
                        Vervis.Federation.Discussion
                        Vervis.Federation.Ticket
                        Vervis.Field.Key