Stop using YesodHttpSig, move code from Foundation to Federation

src/Vervis/Federation.hs

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

src/Vervis/Foundation.hs

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

src/Vervis/Handler/Inbox.hs

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