From d3e14b3edfa61776f8e4a92dd64fe00c7e429b3a Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 21 Feb 2019 23:59:53 +0000 Subject: [PATCH] Add LocalURI type for recording shared URI host --- config/models | 10 +- migrations/2019_02_03_verifkey.model | 4 +- src/Network/FedURI.hs | 41 ++- src/Vervis/Foundation.hs | 136 +++++----- src/Vervis/Handler/Inbox.hs | 50 ++-- src/Vervis/Handler/Person.hs | 11 +- src/Vervis/Model.hs | 2 +- src/Web/ActivityPub.hs | 367 +++++++++++++++++---------- 8 files changed, 379 insertions(+), 242 deletions(-) diff --git a/config/models b/config/models index 7f736ae..e7699e0 100644 --- a/config/models +++ b/config/models @@ -40,13 +40,13 @@ Person UniquePersonEmail email VerifKey - ident FedURI + ident LocalURI instance InstanceId expires UTCTime Maybe public PublicKey sharer RemoteSharerId Maybe - UniqueVerifKey ident + UniqueVerifKey instance ident VerifKeySharedUsage key VerifKeyId @@ -55,11 +55,11 @@ VerifKeySharedUsage UniqueVerifKeySharedUsage key user RemoteSharer - ident FedURI + ident LocalURI instance InstanceId - inbox FedURI + inbox LocalURI - UniqueRemoteSharer ident + UniqueRemoteSharer instance ident Instance host Text diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 6a688d6..47cc716 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -5,7 +5,7 @@ VerifKey public ByteString sharer RemoteSharerId Maybe - UniqueVerifKey ident + UniqueVerifKey instance ident VerifKeySharedUsage key VerifKeyId @@ -18,7 +18,7 @@ RemoteSharer instance InstanceId inbox Text - UniqueRemoteSharer ident + UniqueRemoteSharer instance ident Instance host Text diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index 5c5a381..8adc6b1 100644 --- a/src/Network/FedURI.hs +++ b/src/Network/FedURI.hs @@ -19,9 +19,15 @@ module Network.FedURI , toURI , renderFedURI + {- , InstanceURI (..) , i2f , f2i + -} + + , LocalURI (..) + , l2f + , f2l ) where @@ -29,13 +35,14 @@ import Prelude import Control.Monad ((<=<)) import Data.Aeson -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) +import Data.Maybe (fromJust) import Data.Text (Text) import Database.Persist.Class (PersistField (..)) import Database.Persist.Sql (PersistFieldSql (..)) import Network.URI -import qualified Data.Text as T (pack, unpack) +import qualified Data.Text as T (pack, unpack, stripPrefix) -- | An absolute URI with the following properties: -- @@ -104,6 +111,7 @@ toURI (FedURI h p f) = URI renderFedURI :: FedURI -> Text renderFedURI = T.pack . flip (uriToString id) "" . toURI +{- newtype InstanceURI = InstanceURI { iuriHost :: Text } @@ -114,3 +122,32 @@ i2f (InstanceURI h) = FedURI h "" "" f2i :: FedURI -> InstanceURI f2i = InstanceURI . furiHost +-} + +data LocalURI = LocalURI + { luriPath :: Text + , luriFragment :: Text + } + deriving Eq + +dummyHost :: Text +dummyHost = "h" + +dummyPrefix :: Text +dummyPrefix = "https://" <> dummyHost + +renderLocalURI :: LocalURI -> Text +renderLocalURI = fromJust . T.stripPrefix dummyPrefix . renderFedURI . l2f dummyHost + +instance PersistField LocalURI where + toPersistValue = toPersistValue . renderLocalURI + fromPersistValue = bimap T.pack (snd . f2l) . parseFedURI . (dummyPrefix <>) <=< fromPersistValue + +instance PersistFieldSql LocalURI where + sqlType = sqlType . fmap renderLocalURI + +l2f :: Text -> LocalURI -> FedURI +l2f h (LocalURI p f) = FedURI h p f + +f2l :: FedURI -> (Text, LocalURI) +f2l (FedURI h p f) = (h, LocalURI p f) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index caca7a3..291b2c3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -573,20 +573,26 @@ sumUpTo limit action1 action2 = do return $ n + m <= limit else return False +-- | Grab instance and remote sharer IDs from the DB, inserting new ones if +-- they can't be found in the DB. The @Maybe Bool@ indicates whether the IDs +-- are newly inserted record: 'Nothing' means they're both new. @Just True@ +-- means the instance record existed but the remote sharer is new. @Just False@ +-- means both the instance and remote sharer existed in the DB. instanceAndActor :: Text - -> FedURI - -> FedURI + -> LocalURI + -> LocalURI -> AppDB (InstanceId, RemoteSharerId, Maybe Bool) -instanceAndActor host uActor uInbox = do - mrs <- getBy $ UniqueRemoteSharer uActor - case mrs of - Nothing -> do - (iid, inew) <- idAndNew <$> insertBy (Instance host) - rsid <- insert $ RemoteSharer uActor iid uInbox - return (iid, rsid, if inew then Nothing else Just True) - Just (Entity rsid rs) -> - return (remoteSharerInstance rs, rsid, Just False) +instanceAndActor host luActor luInbox = do + (iid, inew) <- idAndNew <$> insertBy (Instance host) + let rs = RemoteSharer luActor iid luInbox + if inew + then do + rsid <- insert rs + return (iid, rsid, Nothing) + else do + (rsid, rsnew) <- idAndNew <$> insertBy rs + return (iid, rsid, Just rsnew) where idAndNew (Left (Entity iid _)) = (iid, False) idAndNew (Right iid) = (iid, True) @@ -601,13 +607,14 @@ keyListedByActor' :: Manager -> InstanceId -> VerifKeyId - -> FedURI - -> FedURI + -> Text + -> LocalURI + -> LocalURI -> Handler (Either String ()) -keyListedByActor' manager iid vkid uKey uActor = do +keyListedByActor' manager iid vkid host luKey luActor = do mresult <- do ments <- runDB $ do - mrs <- getBy $ UniqueRemoteSharer uActor + mrs <- getBy $ UniqueRemoteSharer iid luActor for mrs $ \ (Entity rsid _) -> (rsid,) . isJust <$> getBy (UniqueVerifKeySharedUsage vkid rsid) @@ -619,10 +626,10 @@ keyListedByActor' manager iid vkid uKey uActor = do then Nothing else Just $ Just rsid runExceptT $ for_ mresult $ \ mrsid -> do - uInbox <- actorInbox <$> ExceptT (keyListedByActor manager uKey uActor) + luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor) ExceptT $ runDB $ case mrsid of Nothing -> do - rsid <- insert $ RemoteSharer uActor iid uInbox + rsid <- insert $ RemoteSharer luActor iid luInbox insert_ $ VerifKeySharedUsage vkid rsid return $ Right () Just rsid -> do @@ -635,16 +642,16 @@ keyListedByActor' manager iid vkid uKey uActor = do data AddVerifKey = AddVerifKey { addvkHost :: Text - , addvkKeyId :: FedURI + , addvkKeyId :: LocalURI , addvkExpires :: Maybe UTCTime , addvkKey :: PublicKey - , addvkActorId :: FedURI - , addvkActorInbox :: FedURI + , addvkActorId :: LocalURI + , addvkActorInbox :: LocalURI } addSharedKey :: AddVerifKey -> AppDB (Maybe String) -addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do - (iid, rsid, inew) <- instanceAndActor host uActor uInbox +addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do + (iid, rsid, inew) <- instanceAndActor host luActor luInbox room <- case inew of Nothing -> pure True @@ -657,7 +664,7 @@ addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do else return False if room then do - vkid <- insert $ VerifKey uKey iid mexpires key Nothing + vkid <- insert $ VerifKey luKey iid mexpires key Nothing insert_ $ VerifKeySharedUsage vkid rsid return Nothing else return $ Just "We already store 2 keys" @@ -666,15 +673,15 @@ addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] addPersonalKey :: AddVerifKey -> AppDB (Maybe String) -addPersonalKey (AddVerifKey host uKey mexpires key uActor uInbox) = do - (iid, rsid, inew) <- instanceAndActor host uActor uInbox +addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do + (iid, rsid, inew) <- instanceAndActor host luActor luInbox room <- if inew == Just False then actorRoom rsid else pure True if room then do - insert_ $ VerifKey uKey iid mexpires key (Just rsid) + insert_ $ VerifKey luKey iid mexpires key (Just rsid) return Nothing else return $ Just "We already store 2 keys" @@ -700,24 +707,24 @@ updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk data VerifKeyDetail = VerifKeyDetail - { vkdKeyId :: FedURI - , vkdInboxOrId :: Either FedURI VerifKeyId + { vkdKeyId :: LocalURI + , vkdInboxOrId :: Either LocalURI VerifKeyId , vkdKey :: PublicKey , vkdExpires :: Maybe UTCTime - , vkdActorId :: FedURI - , vkdHost :: Text + , vkdActorId :: LocalURI , vkdShared :: Bool } -makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate -makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) = - case iori of - Left uInbox -> - let avk = AddVerifKey host uKey mexpires key uActor uInbox - in if shared - then VKUAddSharedKey avk - else VKUAddPersonalKey avk - Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key +makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate +makeVerifKeyUpdate + host (VerifKeyDetail luKey iori key mexpires luActor shared) = + case iori of + Left luInbox -> + let avk = AddVerifKey host luKey mexpires key luActor luInbox + in if shared + then VKUAddSharedKey avk + else VKUAddPersonalKey avk + Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key instance YesodHttpSig App where data HttpSigVerResult App = HttpSigVerResult (Either String FedURI) @@ -734,28 +741,30 @@ instance YesodHttpSig App where case algo of S.AlgorithmEd25519 -> Right () S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" - uKey <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of + (host, luKey) <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e - Right uri -> Right uri + Right uri -> Right $ f2l uri signature <- ExceptT . pure $ do case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" - muActorHeader <- do + mluActorHeader <- do bs <- lookupHeaders hActivityPubActor case bs of [] -> return Nothing [b] -> fmap Just . ExceptT . pure $ do t <- first displayException $ decodeUtf8' b - u <- parseFedURI t - if furiHost u == furiHost uKey + (h, lu) <- f2l <$> parseFedURI t + if h == host then Right () else Left "Key and actor have different hosts" - Right u + Right lu _ -> throwE "Multiple ActivityPub-Actor headers" vkd <- do ments <- lift $ runDB $ do - mvk <- getBy $ UniqueVerifKey uKey + mvk <- runMaybeT $ do + Entity iid _ <- MaybeT $ getBy $ UniqueInstance host + MaybeT $ getBy $ UniqueVerifKey iid luKey for mvk $ \ vk@(Entity _ verifkey) -> do mremote <- traverse getJust $ verifKeySharer verifkey return (vk, mremote) @@ -765,30 +774,29 @@ instance YesodHttpSig App where case mremote of Just remote -> do let sharer = remoteSharerIdent remote - for_ muActorHeader $ \ u -> + for_ mluActorHeader $ \ u -> if sharer == u then return () else throwE "Key's owner doesn't match actor header" return (sharer, False) Nothing -> do - ua <- case muActorHeader of + ua <- case mluActorHeader of Nothing -> throwE "Got a sig with an instance key, but actor header not specified!" Just u -> return u manager <- getsYesod appHttpManager let iid = verifKeyInstance vk ExceptT $ - keyListedByActor' manager iid vkid uKey ua + keyListedByActor' manager iid vkid host luKey ua return (ua, True) return VerifKeyDetail - { vkdKeyId = uKey + { vkdKeyId = luKey , vkdInboxOrId = Right vkid , vkdKey = verifKeyPublic vk , vkdExpires = verifKeyExpires vk , vkdActorId = ua - , vkdHost = furiHost uKey , vkdShared = s } - Nothing -> fetched2vkd uKey <$> fetchKey' muActorHeader uKey + Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" @@ -804,17 +812,14 @@ instance YesodHttpSig App where else Just vkd else if existsInDB then do - Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader uKey + Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey if vkdShared vkd == s then return () else throwE "Key scope changed, we reject that" - if vkdShared vkd - then if h == vkdHost vkd - then return () - else fail "BUG! We re-fetched a key and the host changed" - else if newActor == vkdActorId vkd - then return () - else throwE "Key owner changed, we reject that" + unless (vkdShared vkd) $ + if newActor == vkdActorId vkd + then return () + else throwE "Key owner changed, we reject that" if stillValid newExp then return () else errTime @@ -828,19 +833,18 @@ instance YesodHttpSig App where then errSig else errTime - for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate - return $ vkdActorId vkd + for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate host + return $ l2f host $ vkdActorId vkd where - fetchKey' mua uk = do + fetchKey' h mua uk = do manager <- getsYesod appHttpManager - ExceptT $ fetchKey manager (isJust malgo) mua uk - fetched2vkd uk (Fetched k mexp ua uinb h s) = VerifKeyDetail + ExceptT $ fetchKey manager (isJust malgo) h mua uk + fetched2vkd uk (Fetched k mexp ua uinb s) = VerifKeyDetail { vkdKeyId = uk , vkdInboxOrId = Left uinb , vkdKey = k , vkdExpires = mexp , vkdActorId = ua - , vkdHost = h , vkdShared = s } diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index b507154..49e4801 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -31,6 +31,7 @@ import Control.Exception (displayException) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson @@ -230,7 +231,8 @@ postOutboxR = do } } manager <- getsYesod appHttpManager - minbox <- fetchInboxURI manager to + let (host, lto) = f2l to + minbox <- fetchInboxURI manager host lto for_ minbox $ \ inbox -> do (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys let (keyID, akey) = @@ -238,38 +240,30 @@ postOutboxR = do then (renderUrl ActorKey1R, akey1) else (renderUrl ActorKey2R, akey2) sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity + eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity case eres' of 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." defaultLayout $ activityWidget widget enctype where - fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI) - fetchInboxURI manager to = do - mrs <- runDB $ getBy $ UniqueRemoteSharer to + fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI) + fetchInboxURI manager h lto = do + mrs <- runDB $ runMaybeT $ do + Entity iid _ <- MaybeT $ getBy $ UniqueInstance h + MaybeT $ getBy $ UniqueRemoteSharer iid lto case mrs of Nothing -> do - eres <- httpGetAP manager to + eres <- fetchAPID manager actorId h lto case eres of - Left (APGetErrorHTTP e) -> do - setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) + Left s -> do + setMessage $ toHtml $ T.pack s return Nothing - Left (APGetErrorJSON e) -> do - setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) - return Nothing - Left (APGetErrorContentType e) -> do - setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e - return Nothing - Right response -> do - let actor = getResponseBody response - if actorId actor /= to - then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" >> return Nothing - else do - let inbox = actorInbox actor - runDB $ do - iid <- either entityKey id <$> insertBy (Instance $ furiHost to) - insert_ $ RemoteSharer to iid inbox - return $ Just inbox + Right actor -> do + let inbox = actorInbox actor + runDB $ do + iid <- either entityKey id <$> insertBy (Instance h) + insert_ $ RemoteSharer lto iid inbox + return $ Just inbox Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent @@ -278,14 +272,14 @@ getActorKey choose route = do liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< getsYesod appActorKeys route2uri <- route2uri' <$> getUrlRender + let (host, id_) = f2l $ route2uri route selectRep $ - provideAP PublicKey - { publicKeyId = route2uri route + provideAP $ Doc host PublicKey + { publicKeyId = id_ , publicKeyExpires = Nothing - , publicKeyOwner = route2uri HomeR + , publicKeyOwner = OwnerInstance , publicKeyPem = PEM "PUBLIC KEY" [] actorKey , publicKeyAlgo = Just AlgorithmEd25519 - , publicKeyShared = True } getActorKey1R :: Handler TypedContent diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 6c1376f..9d22980 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -132,18 +132,19 @@ getPerson shr person = do case parseFedURI $ renderUrl route of Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e Right u -> u - me = route2uri $ SharerR shr + route2local = snd . f2l . route2uri + (host, me) = f2l $ route2uri $ SharerR shr selectRep $ do provideRep $ do secure <- getSecure defaultLayout $(widgetFile "person") - provideAP Actor + provideAP $ Doc host Actor { actorId = me , actorType = ActorTypePerson , actorUsername = shr2text shr - , actorInbox = route2uri InboxR + , actorInbox = route2local InboxR , actorPublicKeys = PublicKeySet - { publicKey1 = Left $ route2uri ActorKey1R - , publicKey2 = Just $ Left $ route2uri ActorKey2R + { publicKey1 = Left $ route2local ActorKey1R + , publicKey2 = Just $ Left $ route2local ActorKey2R } } diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index b23e842..6811496 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -28,7 +28,7 @@ import Yesod.Auth.Account (PersistUserCredentials (..)) import Database.Persist.EmailAddress import Database.Persist.Graph.Class -import Network.FedURI (FedURI) +import Network.FedURI (FedURI, LocalURI) import Vervis.Model.Group import Vervis.Model.Ident diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 1b0df66..5b0b4b0 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -14,12 +14,21 @@ -} module Web.ActivityPub - ( -- * Actor + ( -- * Type-safe manipulation tools + -- + -- Types and functions that make handling URIs and JSON-LD contexts less + -- error-prone and safer by recording safety checks in the type and + -- placing the checks in a single clear place. + ActivityPub (..) + , Doc (..) + + -- * Actor -- -- ActivityPub actor document including a public key, with a 'FromJSON' -- instance for fetching and a 'ToJSON' instance for publishing. - ActorType (..) + , ActorType (..) , Algorithm (..) + , Owner (..) , PublicKey (..) , PublicKeySet (..) , Actor (..) @@ -36,6 +45,7 @@ module Web.ActivityPub , httpGetAP , httpPostAP , Fetched (..) + , fetchAPID , keyListedByActor , fetchKey ) @@ -45,24 +55,26 @@ import Prelude import Control.Applicative ((<|>), optional) import Control.Exception (Exception, displayException, try) -import Control.Monad (unless, (<=<)) +import Control.Monad (when, unless, (<=<)) import Control.Monad.IO.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) import Crypto.Error (CryptoFailable (..)) import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Bifunctor (bimap, first) +import Data.Aeson.Encoding (pair) +import Data.Aeson.Types (Parser, typeMismatch, listEncoding) +import Data.Bifunctor import Data.Bitraversable (bitraverse) import Data.ByteString (ByteString) import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty) +import Data.Proxy import Data.PEM import Data.Semigroup (Endo) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time.Clock (UTCTime) -import Network.HTTP.Client +import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Client.Signature (signRequest) import Network.HTTP.Signature (KeyId, Signature) @@ -81,14 +93,58 @@ import Network.FedURI import Data.Aeson.Local +proxy :: a -> Proxy a +proxy _ = Proxy + as2context :: Text as2context = "https://www.w3.org/ns/activitystreams" -actorContext :: Value -actorContext = Array $ V.fromList - [ String as2context - , String "https://w3id.org/security/v1" - ] +secContext :: Text +secContext = "https://w3id.org/security/v1" + +actorContext :: [Text] +actorContext = [as2context, secContext] + +data Context = ContextAS2 | ContextPKey | ContextActor deriving Eq + +instance FromJSON Context where + parseJSON (String t) + | t == as2context = return ContextAS2 + | t == secContext = return ContextPKey + parseJSON (Array v) + | V.toList v == map String actorContext = return ContextActor + parseJSON _ = fail "Unrecognized @context" + +instance ToJSON Context where + toJSON = error "toJSON Context" + toEncoding ContextAS2 = toEncoding as2context + toEncoding ContextPKey = toEncoding secContext + toEncoding ContextActor = toEncoding actorContext + +class ActivityPub a where + jsonldContext :: Proxy a -> Context + parseObject :: Object -> Parser (Text, a) + toSeries :: Text -> a -> Series + +data Doc a = Doc + { docHost :: Text + , docValue :: a + } + +instance ActivityPub a => FromJSON (Doc a) where + parseJSON = withObject "Doc" $ \ o -> do + (h, v) <- parseObject o + ctx <- o .: "@context" + if ctx == jsonldContext (proxy v) + then return $ Doc h v + else fail "@context doesn't match" + +instance ActivityPub a => ToJSON (Doc a) where + toJSON = error "toJSON Doc" + toEncoding (Doc h v) = + pairs + $ "@context" .= jsonldContext (proxy v) + <> toSeries h v data ActorType = ActorTypePerson | ActorTypeOther Text @@ -120,32 +176,44 @@ instance ToJSON Algorithm where AlgorithmEd25519 -> frg <> "ed25519" AlgorithmOther t -> t +data Owner = OwnerInstance | OwnerActor LocalURI + +ownerShared :: Owner -> Bool +ownerShared OwnerInstance = True +ownerShared (OwnerActor _) = False + data PublicKey = PublicKey - { publicKeyId :: FedURI + { publicKeyId :: LocalURI , publicKeyExpires :: Maybe UTCTime - , publicKeyOwner :: FedURI + , publicKeyOwner :: Owner , publicKeyPem :: PEM , publicKeyAlgo :: Maybe Algorithm - , publicKeyShared :: Bool } -instance FromJSON PublicKey where - parseJSON = withObject "PublicKey" $ \ o -> do +instance ActivityPub PublicKey where + jsonldContext _ = ContextPKey + parseObject o = do mtyp <- optional $ o .: "@type" <|> o .: "type" - case mtyp of - Nothing -> return () - Just t -> - if t == ("Key" :: Text) - then return () - else fail "PublicKey @type isn't Key" - PublicKey - <$> o .: "id" - <*> o .:? "expires" - <*> o .: "owner" - <*> (parsePEM =<< o .: "publicKeyPem") - <*> o .:? (frg <> "algorithm") - <*> o .:? (frg <> "shared") .!= False + for_ mtyp $ \ t -> + when (t /= ("Key" :: Text)) $ + fail "PublicKey @type isn't Key" + (host, id_) <- f2l <$> (o .: "@id" <|> o .: "id") + shared <- o .: (frg <> "isShared") .!= False + fmap (host,) $ + PublicKey id_ + <$> o .:? "expires" + <*> (mkOwner shared =<< withHost host o "owner") + <*> (parsePEM =<< o .: "publicKeyPem") + <*> o .:? (frg <> "algorithm") where + withHost h o t = do + (h', lu) <- f2l <$> o .: t + if h == h' + then return lu + else fail "URI host mismatch" + mkOwner True (LocalURI "" "") = return OwnerInstance + mkOwner True _ = fail "Shared key but owner isn't instance URI" + mkOwner False lu = return $ OwnerActor lu parsePEM t = case pemParseBS $ encodeUtf8 t of Left e -> fail $ "PEM parsing failed: " ++ e @@ -154,73 +222,84 @@ instance FromJSON PublicKey where [] -> fail "Empty PEM" [x] -> pure x _ -> fail "Multiple PEM sections" - -instance ToJSON PublicKey where - toJSON = error "toJSON PublicKey" - toEncoding (PublicKey id_ mexpires owner pem malgo shared) = - pairs - $ "id" .= id_ - <> "expires" .=? mexpires - <> "owner" .= owner - <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem) - <> (frg <> "algorithm") .=? malgo - <> (frg <> "shared") .= shared + toSeries host (PublicKey id_ mexpires owner pem malgo) + = "@id" .= l2f host id_ + <> "expires" .=? mexpires + <> "owner" .= mkOwner host owner + <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem) + <> (frg <> "algorithm") .=? malgo + <> (frg <> "isShared") .= ownerShared owner + where + mkOwner h OwnerInstance = FedURI h "" "" + mkOwner h (OwnerActor lu) = l2f h lu data PublicKeySet = PublicKeySet - { publicKey1 :: Either FedURI PublicKey - , publicKey2 :: Maybe (Either FedURI PublicKey) + { publicKey1 :: Either LocalURI PublicKey + , publicKey2 :: Maybe (Either LocalURI PublicKey) } -instance FromJSON PublicKeySet where - parseJSON v = - case v of - Array a -> - case V.toList a of - [] -> fail "No public keys" - [k1] -> PublicKeySet <$> parseKey k1 <*> pure Nothing - [k1, k2] -> PublicKeySet <$> parseKey k1 <*> (Just <$> parseKey k2) - _ -> fail "More than 2 public keys isn't supported" - _ -> PublicKeySet <$> parseKey v <*> pure Nothing - where - parseKey = fmap toEither . parseJSON +parsePublicKeySet :: Value -> Parser (Text, PublicKeySet) +parsePublicKeySet v = + case v of + Array a -> + case V.toList a of + [] -> fail "No public keys" + [k1] -> second (flip PublicKeySet Nothing) <$> parseKey k1 + [k1, k2] -> do + (h, e1) <- parseKey k1 + e2 <- withHost h $ parseKey k2 + return (h, PublicKeySet e1 $ Just e2) + _ -> fail "More than 2 public keys isn't supported" + _ -> second (flip PublicKeySet Nothing) <$> parseKey v + where + parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t) + parseKey (Object o) = second Right <$> parseObject o + parseKey v = typeMismatch "PublicKeySet Item" v + withHost h a = do + (h', v) <- a + if h == h' + then return v + else fail "URI host mismatch" -instance ToJSON PublicKeySet where - toJSON = error "toJSON PublicKeySet" - toEncoding (PublicKeySet k1 mk2) = - case mk2 of - Nothing -> toEncoding $ renderKey k1 - Just k2 -> toEncodingList [renderKey k1, renderKey k2] - where - renderKey = fromEither +encodePublicKeySet :: Text -> PublicKeySet -> Encoding +encodePublicKeySet host (PublicKeySet k1 mk2) = + case mk2 of + Nothing -> renderKey k1 + Just k2 -> listEncoding renderKey [k1, k2] + where + renderKey (Left lu) = toEncoding $ l2f host lu + renderKey (Right pk) = pairs $ toSeries host pk data Actor = Actor - { actorId :: FedURI + { actorId :: LocalURI , actorType :: ActorType , actorUsername :: Text - , actorInbox :: FedURI + , actorInbox :: LocalURI , actorPublicKeys :: PublicKeySet } -instance FromJSON Actor where - parseJSON = withObject "Actor" $ \ o -> - Actor - <$> o .: "id" - <*> o .: "type" - <*> o .: "preferredUsername" - <*> o .: "inbox" - <*> o .: "publicKey" - -instance ToJSON Actor where - toJSON = error "toJSON Actor" - toEncoding (Actor id_ typ username inbox pkeys) = - pairs - $ "@context" .= actorContext - <> "id" .= id_ - <> "type" .= typ - <> "preferredUsername" .= username - <> "inbox" .= inbox - <> "publicKey" .= pkeys - +instance ActivityPub Actor where + jsonldContext _ = ContextActor + parseObject o = do + (host, id_) <- f2l <$> o .: "id" + fmap (host,) $ + Actor id_ + <$> o .: "type" + <*> o .: "preferredUsername" + <*> withHost host (f2l <$> o .: "inbox") + <*> withHost host (parsePublicKeySet =<< o .: "publicKey") + where + withHost h a = do + (h', v) <- a + if h == h' + then return v + else fail "URI host mismatch" + toSeries host (Actor id_ typ username inbox pkeys) + = "id" .= l2f host id_ + <> "type" .= typ + <> "preferredUsername" .= username + <> "inbox" .= l2f host inbox + <> "publicKey" `pair` encodePublicKeySet host pkeys data Note = Note { noteId :: FedURI , noteAttrib :: FedURI @@ -390,12 +469,10 @@ data Fetched = Fetched -- ^ The Ed25519 public key corresponding to the URI we requested. , fetchedKeyExpires :: Maybe UTCTime -- ^ Optional expiration time declared for the key we received. - , fetchedActorId :: FedURI + , fetchedActorId :: LocalURI -- ^ The @id URI of the actor for whom the key's signature applies. - , fetchedActorInbox :: FedURI + , fetchedActorInbox :: LocalURI -- ^ The inbox URI of the actor for whom the key's signature applies. - , fetchedHost :: Text - -- ^ The domain name of the instance from which we got the key. , fetchedKeyShared :: Bool -- ^ Whether the key we received is shared. A shared key can sign -- requests for any actor on the same instance, while a personal key is @@ -405,16 +482,50 @@ data Fetched = Fetched -- we received. } +fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a +fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP m u + +fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a +fetchAPH m h lu = do + Doc h' v <- fetchAP m $ l2f h lu + if h == h' + then return v + else throwE "Object @id URI's host doesn't match the URI we fetched" + +fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a) +fetchAPID m getId h lu = runExceptT $ do + Doc h' v <- fetchAP m $ l2f h lu + if h == h' && getId v == lu + then return v + else throwE "Object @id doesn't match the URI we fetched" + +fetchAPIDOrH + :: (MonadIO m, ActivityPub a, ActivityPub b) + => Manager + -> (a -> LocalURI) + -> Text + -> LocalURI + -> ExceptT String m (Either a b) +fetchAPIDOrH m getId h lu = do + e <- fetchAP m $ l2f h lu + case e of + Left' (Doc h' x) -> + if h == h' && getId x == lu + then return $ Left x + else throwE "Object @id doesn't match the URI we fetched" + Right' (Doc h' y) -> + if h == h' + then return $ Right y + else throwE "Object @id URI's host doesn't match the URI we fetched" + -- | Fetches the given actor and checks whether it lists the given key (as a -- URI, not as an embedded object). If it does, returns 'Right' the fetched -- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an -- error message. -keyListedByActor :: MonadIO m => Manager -> FedURI -> FedURI -> m (Either String Actor) -keyListedByActor manager uKey uActor = runExceptT $ do - let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a - fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u - actor <- fetch uActor - if keyUriListed uKey actor +keyListedByActor :: MonadIO m => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor) +keyListedByActor manager host luKey luActor = runExceptT $ do + actor <- ExceptT $ fetchAPID manager actorId host luActor + if keyUriListed luKey actor then return actor else throwE "Actor publicKey has no URI matching pkey @id" where @@ -428,63 +539,54 @@ fetchKey :: MonadIO m => Manager -> Bool - -> Maybe FedURI - -> FedURI + -> Text + -> Maybe LocalURI + -> LocalURI -> m (Either String Fetched) -fetchKey manager sigAlgo muActor uKey = runExceptT $ do - let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a - fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u - obj <- fetch uKey - let inztance = f2i uKey +fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do + obj <- fetchAPIDOrH manager publicKeyId host luKey (actor, pkey) <- case obj of - Left' pkey -> do - if publicKeyId pkey == uKey - then return () - else throwE "Public key's ID doesn't match the keyid URI" - if furiHost (publicKeyOwner pkey) == furiHost uKey - then return () - else throwE "Actor and key on different domains, we reject" - uActor <- - if publicKeyShared pkey - then case muActor of - Nothing -> throwE "Key is shared but actor header not specified!" - Just u -> return u - else do - let owner = publicKeyOwner pkey - for_ muActor $ \ u -> - if owner == u + Left pkey -> do + luActor <- + case publicKeyOwner pkey of + OwnerInstance -> + case mluActor of + Nothing -> throwE "Key is shared but actor header not specified!" + Just u -> return u + OwnerActor owner -> do + for_ mluActor $ \ lu -> + if owner == lu then return () else throwE "Key's owner doesn't match actor header" return owner - actor <- ExceptT $ keyListedByActor manager uKey uActor + actor <- ExceptT $ keyListedByActor manager host luKey luActor return (actor, pkey) - Right' actor -> do - if actorId actor == uKey { furiFragment = "" } + Right actor -> do + if actorId actor == luKey { luriFragment = "" } then return () else throwE "Actor ID doesn't match the keyid URI we fetched" - for_ muActor $ \ u -> - if actorId actor == u + for_ mluActor $ \ lu -> + if actorId actor == lu then return () else throwE "Key's owner doesn't match actor header" let PublicKeySet k1 mk2 = actorPublicKeys actor match (Left _) = Nothing match (Right pk) = - if publicKeyId pk == uKey + if publicKeyId pk == luKey then Just pk else Nothing case match k1 <|> (match =<< mk2) of Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" Just pk -> - if publicKeyShared pk - then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" - else return (actor, pk) + case publicKeyOwner pk of + OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" + OwnerActor _ -> return (actor, pk) ExceptT . pure $ do - if publicKeyShared pkey - then if publicKeyOwner pkey == i2f inztance - then Right () - else Left "Key is shared but its owner isn't the top-level instance URI" - else if publicKeyOwner pkey == actorId actor + case publicKeyOwner pkey of + OwnerInstance -> Right () + OwnerActor owner -> + if owner == actorId actor then Right () else Left "Actor's publicKey's owner doesn't match the actor's ID" case publicKeyAlgo pkey of @@ -507,7 +609,6 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = actorId actor , fetchedActorInbox = actorInbox actor - , fetchedHost = furiHost uKey - , fetchedKeyShared = publicKeyShared pkey + , fetchedKeyShared = ownerShared $ publicKeyOwner pkey } CryptoFailed _ -> Left "Parsing Ed25519 public key failed"