sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2025-01-15 19:55:09 +09:00
Code Issues Activity

Adapt Activity/Create/Note to new ActivityPub typeclass and add safety checks

Browse source
This commit is contained in:
fr33domlover 2019-03-10 06:42:03 +00:00
parent 61d1aa6720
commit ef57f29a54
2 changed files with 75 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
src/Vervis/Handler/Inbox.hs
View file

@ -28,9 +28,10 @@ import Prelude
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar') import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
import Control.Exception (displayException) import Control.Exception (displayException)
import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.STM (atomically) import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Crypto.Error (CryptoFailable (..)) import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
@ -129,7 +130,7 @@ postInboxR = do
Left _ -> notAuthenticated Left _ -> notAuthenticated
where where
liftE = ExceptT . pure liftE = ExceptT . pure
getActivity :: UTCTime -> ExceptT String Handler (ContentType, Activity) getActivity :: UTCTime -> ExceptT String Handler (ContentType, Doc Activity)
getActivity now = do getActivity now = do
contentType <- do contentType <- do
ctypes <- lookupHeaders "Content-Type" ctypes <- lookupHeaders "Content-Type"
@ -141,16 +142,13 @@ postInboxR = do
_ -> Left "Unknown Content-Type" _ -> Left "Unknown Content-Type"
_ -> Left "More than one Content-Type given" _ -> Left "More than one Content-Type given"
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
uActor <- liftE result (h, luActor) <- f2l <$> liftE result
a@(CreateActivity c) <- requireJsonBody d@(Doc h' (CreateActivity c)) <- requireJsonBody
liftE $ do unless (h == h') $
if createActor c == uActor throwE "Activity host doesn't match signature key host"
then Right () unless (createActor c == luActor) $
else Left "Activity's actor != Signature key's actor" throwE "Activity's actor != Signature key's actor"
if noteAttrib (createObject c) == uActor return (contentType, d)
then Right ()
else Left "Activity object's actor doesn't match activity's actor"
return (contentType, a)
{- {-
jsonField :: (FromJSON a, ToJSON a) => Field Handler a jsonField :: (FromJSON a, ToJSON a) => Field Handler a
@ -217,17 +215,15 @@ postOutboxR = do
return $ sharerIdent sharer return $ sharerIdent sharer
renderUrl <- getUrlRender renderUrl <- getUrlRender
let route2uri = route2uri' renderUrl let route2uri = route2uri' renderUrl
actor = route2uri $ SharerR shr (h, actor) = f2l $ route2uri $ SharerR shr
actorID = renderUrl $ SharerR shr actorID = renderUrl $ SharerR shr
appendPath u t = u { furiPath = furiPath u <> t } appendPath u t = u { luriPath = luriPath u <> t }
activity = CreateActivity Create activity = CreateActivity Create
{ createId = appendPath actor "/fake-activity" { createId = appendPath actor "/fake-activity"
, createTo = to , createTo = to
, createActor = actor , createActor = actor
, createObject = Note , createObject = Note
{ noteId = appendPath actor "/fake-note" { noteId = appendPath actor "/fake-note"
, noteAttrib = actor
, noteTo = to
, noteReplyTo = Nothing , noteReplyTo = Nothing
, noteContent = msg , noteContent = msg
} }
@ -242,7 +238,7 @@ postOutboxR = do
then (renderUrl ActorKey1R, akey1) then (renderUrl ActorKey1R, akey1)
else (renderUrl ActorKey2R, akey2) else (renderUrl ActorKey2R, akey2)
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID $ Doc h activity
case eres' of case eres' of
Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."

126
src/Web/ActivityPub.hs
View file

@ -30,7 +30,6 @@ module Web.ActivityPub
, Algorithm (..) , Algorithm (..)
, Owner (..) , Owner (..)
, PublicKey (..) , PublicKey (..)
--, PublicKeySet (..)
, Actor (..) , Actor (..)
-- * Activity -- * Activity
@ -236,13 +235,6 @@ instance ActivityPub PublicKey where
mkOwner h OwnerInstance = FedURI h "" "" mkOwner h OwnerInstance = FedURI h "" ""
mkOwner h (OwnerActor lu) = l2f h lu mkOwner h (OwnerActor lu) = l2f h lu
{-
data PublicKeySet = PublicKeySet
{ publicKey1 :: Either LocalURI PublicKey
, publicKey2 :: Maybe (Either LocalURI PublicKey)
}
-}
parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey)) parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey))
parsePublicKeySet v = parsePublicKeySet v =
case v of case v of
@ -303,81 +295,87 @@ instance ActivityPub Actor where
<> "preferredUsername" .= username <> "preferredUsername" .= username
<> "inbox" .= l2f host inbox <> "inbox" .= l2f host inbox
<> "publicKey" `pair` encodePublicKeySet host pkeys <> "publicKey" `pair` encodePublicKeySet host pkeys
data Note = Note data Note = Note
{ noteId :: FedURI { noteId :: LocalURI
, noteAttrib :: FedURI --, noteAttrib :: LocalURI
, noteTo :: FedURI --, noteTo :: FedURI
, noteReplyTo :: Maybe FedURI , noteReplyTo :: Maybe FedURI
, noteContent :: Text , noteContent :: Text
} }
instance FromJSON Note where parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI))
parseJSON = withObject "Note" $ \ o -> do parseNote = withObject "Note" $ \ o -> do
typ <- o .: "type" typ <- o .: "type"
unless (typ == ("Note" :: Text)) $ fail "type isn't Note" unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
Note (h, id_) <- f2l <$> o .: "id"
<$> o .: "id" fmap (h,) $
<*> o .: "attributedTo" (,,) <$> (Note id_
<*> o .: "to" <$> o .:? "inReplyTo"
<*> o .:? "inReplyTo" <*> o .: "content"
<*> o .: "content" )
<*> withHost h (f2l <$> o .: "attributedTo")
<*> o .: "to"
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
instance ToJSON Note where encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding
toJSON = error "toJSON Note" encodeNote host (Note id_ mreply content) attrib to =
toEncoding (Note id_ attrib to mreply content) = pairs
pairs $ "type" .= ("Note" :: Text)
$ "type" .= ("Note" :: Text) <> "id" .= l2f host id_
<> "id" .= id_ <> "attributedTo" .= l2f host attrib
<> "attributedTo" .= attrib <> "to" .= to
<> "to" .= to <> "inReplyTo" .=? mreply
<> "inReplyTo" .=? mreply <> "content" .= content
<> "content" .= content
data Create = Create data Create = Create
{ createId :: FedURI { createId :: LocalURI
, createTo :: FedURI , createTo :: FedURI
, createActor :: FedURI , createActor :: LocalURI
, createObject :: Note , createObject :: Note
} }
instance FromJSON Create where parseCreate :: Object -> Parser (Text, Create)
parseJSON = withObject "Create" $ \ o -> do parseCreate o = do
typ <- o .: "type" typ <- o .: "type"
unless (typ == ("Create" :: Text)) $ fail "type isn't Create" unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
Create (h, id_) <- f2l <$> o .: "id"
<$> o .: "id" luActor <- withHost h $ f2l <$> o .: "actor"
<*> o .: "to" (note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
<*> o .: "actor" unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
<*> o .: "object" uTo' <- o .: "to"
unless (uTo == uTo') $ fail "Create to != Note to"
return (h, Create id_ uTo luActor note)
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
instance ToJSON Create where encodeCreate :: Text -> Create -> Series
toJSON = error "toJSON Create" encodeCreate host (Create id_ to actor obj)
toEncoding (Create id_ to actor obj) = = "type" .= ("Create" :: Text)
pairs <> "id" .= l2f host id_
$ "@context" .= as2context <> "to" .= to
<> "type" .= ("Create" :: Text) <> "actor" .= l2f host actor
<> "id" .= id_ <> "object" `pair` encodeNote host obj actor to
<> "to" .= to
<> "actor" .= actor
<> "object" .= obj
data Activity = CreateActivity Create data Activity = CreateActivity Create
instance FromJSON Activity where instance ActivityPub Activity where
parseJSON = withObject "Activity" $ \ o -> do jsonldContext _ = ContextAS2
ctx <- o .: "@context" parseObject o = do
if ctx == as2context
then return ()
else fail "@context isn't the AS2 context URI"
typ <- o .: "type" typ <- o .: "type"
let v = Object o
case typ of case typ of
"Create" -> CreateActivity <$> parseJSON v "Create" -> second CreateActivity <$> parseCreate o
_ -> fail $ "Unrecognized activity type: " ++ T.unpack typ _ -> fail $ "Unrecognized activity type: " ++ T.unpack typ
toSeries host (CreateActivity c) = encodeCreate host c
instance ToJSON Activity where
toJSON = error "toJSON Activity"
toEncoding (CreateActivity c) = toEncoding c
typeActivityStreams2 :: ContentType typeActivityStreams2 :: ContentType
typeActivityStreams2 = "application/activity+json" typeActivityStreams2 = "application/activity+json"