Back to using the (updated) YesodHttpSig class

src/Vervis/Foundation.hs

@@ -18,6 +18,7 @@ module Vervis.Foundation where
 import Prelude (init, last)
 
 import Control.Monad.Logger.CallStack (logWarn)
+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
 import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
 import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
@@ -27,8 +28,8 @@ import Data.Time.Units (Second, Minute, Day)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Graphics.SVGFonts.ReadFont (PreparedFont)
 import Network.HTTP.Client (Manager, HttpException, requestFromURI)
-import Network.HTTP.Simple (httpJSONEither, getResponseBody)
+import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
-import Network.URI (uriFragment, parseURI)
+import Network.URI (URI (uriFragment), parseURI)
 import Text.Shakespeare.Text (textFile)
 import Text.Hamlet          (hamletFile)
 --import Text.Jasmine         (minifym)
@@ -560,72 +561,69 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
 
-{-
 instance YesodHttpSig App where
-    data HttpSigVerResult App = HttpSigVerResult Bool
+    data HttpSigVerResult App = HttpSigVerResult (Either String URI)
     httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"]
     httpSigVerSeconds =
         fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
         where
         toSeconds :: TimeInterval -> Second
         toSeconds = toTimeUnit
-    httpVerifySig malgo (KeyId keyid) input (Signature sig) =
+    httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
-        if algoSupported malgo
+        ExceptT . pure $ case malgo of
-            then case parseURI $ BC.unpack keyid of
+            Nothing -> Right ()
-                Just u -> do
+            Just algo ->
-                    eres <- try $ httpJSONEither =<< requestFromURI u
+                case algo of
-                    case eres of
+                    S.AlgorithmEd25519 -> Right ()
-                        Left e -> do
+                    S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
-                            logWarn $ "httpVerifySig got HTTP exception: " <> T.pack (displayException (e :: HttpException))
+        u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
-                            -- return HttpSigVerKeyNotFound
+            Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
-                            return $ HttpSigVerResult False
+            Just uri -> Right uri
-                        Right r ->
+        manager <- getsYesod appHttpManager
-                            case getResponseBody r of
+        response <-
-                                Left e -> do
+            ExceptT $ first (displayException :: HttpException -> String) <$>
-                                    logWarn $ "httpVerifySig got JSON exception: " <> T.pack (displayException e)
+                (try $
-                                    -- return HttpSigVerKeyNotFound
+                    httpJSONEither .
-                                    return $ HttpSigVerResult False
+                    addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
-                                Right actor -> do
+                    setRequestManager manager
-                                    let uActor = u { uriFragment = "" }
+                        =<< requestFromURI u
-                                    if uActor == actorId actor
+                )
-                                        then
+        ExceptT . pure $ do
-                                            let pkey = actorPublicKey actor
+            actor <- first displayException $ getResponseBody response
-                                            in  if publicKeyId pkey == u && publicKeyOwner pkey == actorId actor
+            let uActor = u { uriFragment = "" }
-                                                    then case publicKeyAlgo pkey of
+            if uActor == actorId actor
-                                                        Just AlgorithmEd25519 ->
+                then Right ()
-                                                            case publicKey $ pemContent $ publicKeyPem pkey of
+                else Left "Actor ID doesn't match the keyid URI we fetched"
-                                                                CryptoPassed k ->
+            let pkey = actorPublicKey actor
-                                                                    case signature sig of
+            if publicKeyId pkey == u
-                                                                        CryptoPassed s ->
+                then Right ()
-                                                                            return $ if verify k input s
+                else Left "Actor's publicKey's ID doesn't match the keyid URI"
-                                                                                then -- HttpSigVerValid
+            if publicKeyOwner pkey == actorId actor
-                                                                                    HttpSigVerResult True
+                then Right ()
-                                                                                else -- HttpSigVerInvalid
+                else Left "Actor's publicKey's owner doesn't match the actor's ID"
-                                                                                    HttpSigVerResult False
+            case publicKeyAlgo pkey of
-                                                                        CryptoFailed e -> -- TODO handle
+                Nothing ->
-                                                                            return $ HttpSigVerResult False
+                    Left $
-                                                                CryptoFailed e -> -- TODO handle
+                    case malgo of
-                                                                    return $ HttpSigVerResult False
+                        Nothing -> "Algo not given in Sig nor actor"
-                                                        _ -> case malgo of
+                        Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
-                                                            Nothing -> -- return HttpSigVerAlgoNotSupported
+                Just algo ->
-                                                                return $ HttpSigVerResult False
+                    case algo of
-                                                            Just _ -> -- return HttpSigVerAlgoMismatch
+                        AlgorithmEd25519 -> Right ()
-                                                                return $ HttpSigVerResult False
+                        AlgorithmOther _ ->
-                                                    else -- TODO handle the mismatch
+                            Left $
-                                                        return $ HttpSigVerResult False
+                            case malgo of
-                                        else -- TODO actor id doesn't match URL we accessed!
+                                Nothing -> "No algo in Sig, unsupported algo in actor"
-                                            return $ HttpSigVerResult False
+                                Just _  -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
-                Nothing -> -- return HttpSigVerKeyNotFound
+            key <- case publicKey $ pemContent $ publicKeyPem pkey of
-                    return $ HttpSigVerResult False
+                CryptoPassed k -> Right k
-            else -- return HttpSigVerAlgoNotSupported
+                CryptoFailed e -> Left "Parsing Ed25519 public key failed"
-                return $ HttpSigVerResult False
+            signature <- case signature sig of
-        where
+                CryptoPassed s -> Right s
-        algoSupported Nothing  = True
+                CryptoFailed e -> Left "Parsing Ed25519 signature failed"
-        algoSupported (Just a) =
+            if verify key input signature
-            case a of
+                then Right uActor
-                S.AlgorithmEd25519 -> True
+                else Left "Ed25519 sig verification says not valid"
-                S.AlgorithmOther _ -> False
--}
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of

src/Vervis/Handler/Inbox.hs

@@ -56,11 +56,12 @@ import qualified Data.Vector as V (length, cons, init)
 import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
 
 import Network.HTTP.Signature hiding (Algorithm (..))
+import Yesod.HttpSignature (verifyRequestSignature)
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
 import Vervis.ActivityPub
-import Vervis.Foundation (App (..), Handler)
+import Vervis.Foundation (App (..), HttpSigVerResult (..), Handler)
 import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
 
 getInboxR :: Handler Html
@@ -127,79 +128,6 @@ postInboxR = do
         Left _ -> notAuthenticated
     where
     liftE = ExceptT . pure
-    verifyActivity :: UTCTime -> ExceptT String Handler URI
-    verifyActivity now = do
-        site <- getYesod
-        wr <- waiRequest
-        let request = Request
-                { requestMethod  = CI.mk $ W.requestMethod wr
-                , requestPath    = W.rawPathInfo wr
-                , requestHeaders = W.requestHeaders wr
-                }
-            toSeconds :: TimeInterval -> Second
-            toSeconds = toTimeUnit
-        (malgo, KeyId keyid, input, Signature sig) <-
-            liftE $
-            first show $
-            prepareToVerify
-                [HeaderTarget, HeaderName "Host"]
-                (fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings $ site)
-                now
-                request
-        liftE $ case malgo of
-            Nothing -> Right ()
-            Just algo ->
-                case algo of
-                    S.AlgorithmEd25519 -> Right ()
-                    S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
-        u <- liftE $ case parseURI $ BC.unpack keyid of
-            Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
-            Just uri -> Right uri
-        manager <- getsYesod appHttpManager
-        response <-
-            ExceptT $ first (displayException :: HttpException -> String) <$>
-                (try $
-                    httpJSONEither .
-                    addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
-                    setRequestManager manager
-                        =<< requestFromURI u
-                )
-        liftE $ do
-            actor <- first displayException $ getResponseBody response
-            let uActor = u { uriFragment = "" }
-            if uActor == actorId actor
-                then Right ()
-                else Left "Actor ID doesn't match the keyid URI we fetched"
-            let pkey = actorPublicKey actor
-            if publicKeyId pkey == u
-                then Right ()
-                else Left "Actor's publicKey's ID doesn't match the keyid URI"
-            if publicKeyOwner pkey == actorId actor
-                then Right ()
-                else Left "Actor's publicKey's owner doesn't match the actor's ID"
-            case publicKeyAlgo pkey of
-                Nothing ->
-                    Left $
-                    case malgo of
-                        Nothing -> "Algo not given in Sig nor actor"
-                        Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
-                Just algo ->
-                    case algo of
-                        AlgorithmEd25519 -> Right ()
-                        AlgorithmOther _ ->
-                            Left $
-                            case malgo of
-                                Nothing -> "No algo in Sig, unsupported algo in actor"
-                                Just _  -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
-            key <- case publicKey $ pemContent $ publicKeyPem pkey of
-                CryptoPassed k -> Right k
-                CryptoFailed e -> Left "Parsing Ed25519 public key failed"
-            signature <- case signature sig of
-                CryptoPassed s -> Right s
-                CryptoFailed e -> Left "Parsing Ed25519 signature failed"
-            if verify key input signature
-                then Right uActor
-                else Left "Ed25519 sig verification says not valid"
     getActivity :: UTCTime -> ExceptT String Handler (ContentType, HashMap Text Value)
     getActivity now = do
         contentType <- do
@@ -211,7 +139,8 @@ postInboxR = do
                     "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
                     _ -> Left "Unknown Content-Type"
                 _ -> Left "More than one Content-Type given"
-        uActor <- verifyActivity now
+        HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
+        uActor <- liftE result
         o <- requireJsonBody
         activityActor <-
             liftE $