sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 01:14:51 +09:00
Code Issues Activity

Add LocalURI type for recording shared URI host

Browse source
This commit is contained in:
fr33domlover 2019-02-21 23:59:53 +00:00
parent aefb2aaee7
commit d3e14b3edf
8 changed files with 379 additions and 242 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
config/models
View file

@ -40,13 +40,13 @@ Person
UniquePersonEmail email UniquePersonEmail email
VerifKey VerifKey
ident FedURI ident LocalURI
instance InstanceId instance InstanceId
expires UTCTime Maybe expires UTCTime Maybe
public PublicKey public PublicKey
sharer RemoteSharerId Maybe sharer RemoteSharerId Maybe
UniqueVerifKey ident UniqueVerifKey instance ident
VerifKeySharedUsage VerifKeySharedUsage
key VerifKeyId key VerifKeyId
@ -55,11 +55,11 @@ VerifKeySharedUsage
UniqueVerifKeySharedUsage key user UniqueVerifKeySharedUsage key user
RemoteSharer RemoteSharer
ident FedURI ident LocalURI
instance InstanceId instance InstanceId
inbox FedURI inbox LocalURI
UniqueRemoteSharer ident UniqueRemoteSharer instance ident
Instance Instance
host Text host Text

4
migrations/2019_02_03_verifkey.model
View file

@ -5,7 +5,7 @@ VerifKey
public ByteString public ByteString
sharer RemoteSharerId Maybe sharer RemoteSharerId Maybe
UniqueVerifKey ident UniqueVerifKey instance ident
VerifKeySharedUsage VerifKeySharedUsage
key VerifKeyId key VerifKeyId
@ -18,7 +18,7 @@ RemoteSharer
instance InstanceId instance InstanceId
inbox Text inbox Text
UniqueRemoteSharer ident UniqueRemoteSharer instance ident
Instance Instance
host Text host Text

41
src/Network/FedURI.hs
View file

@ -19,9 +19,15 @@ module Network.FedURI
, toURI , toURI
, renderFedURI , renderFedURI
{-
, InstanceURI (..) , InstanceURI (..)
, i2f , i2f
, f2i , f2i
-}
, LocalURI (..)
, l2f
, f2l
) )
where where
@ -29,13 +35,14 @@ import Prelude
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Data.Aeson import Data.Aeson
import Data.Bifunctor (first) import Data.Bifunctor (bimap, first)
import Data.Maybe (fromJust)
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Class (PersistField (..)) import Database.Persist.Class (PersistField (..))
import Database.Persist.Sql (PersistFieldSql (..)) import Database.Persist.Sql (PersistFieldSql (..))
import Network.URI 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: -- | An absolute URI with the following properties:
-- --
@ -104,6 +111,7 @@ toURI (FedURI h p f) = URI
renderFedURI :: FedURI -> Text renderFedURI :: FedURI -> Text
renderFedURI = T.pack . flip (uriToString id) "" . toURI renderFedURI = T.pack . flip (uriToString id) "" . toURI
{-
newtype InstanceURI = InstanceURI newtype InstanceURI = InstanceURI
{ iuriHost :: Text { iuriHost :: Text
} }
@ -114,3 +122,32 @@ i2f (InstanceURI h) = FedURI h "" ""
f2i :: FedURI -> InstanceURI f2i :: FedURI -> InstanceURI
f2i = InstanceURI . furiHost 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)

136
src/Vervis/Foundation.hs
View file

@ -573,20 +573,26 @@ sumUpTo limit action1 action2 = do
return $ n + m <= limit return $ n + m <= limit
else return False 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 instanceAndActor
:: Text :: Text
-> FedURI -> LocalURI
-> FedURI -> LocalURI
-> AppDB (InstanceId, RemoteSharerId, Maybe Bool) -> AppDB (InstanceId, RemoteSharerId, Maybe Bool)
instanceAndActor host uActor uInbox = do instanceAndActor host luActor luInbox = do
mrs <- getBy $ UniqueRemoteSharer uActor (iid, inew) <- idAndNew <$> insertBy (Instance host)
case mrs of let rs = RemoteSharer luActor iid luInbox
Nothing -> do if inew
(iid, inew) <- idAndNew <$> insertBy (Instance host) then do
rsid <- insert $ RemoteSharer uActor iid uInbox rsid <- insert rs
return (iid, rsid, if inew then Nothing else Just True) return (iid, rsid, Nothing)
Just (Entity rsid rs) -> else do
return (remoteSharerInstance rs, rsid, Just False) (rsid, rsnew) <- idAndNew <$> insertBy rs
return (iid, rsid, Just rsnew)
where where
idAndNew (Left (Entity iid _)) = (iid, False) idAndNew (Left (Entity iid _)) = (iid, False)
idAndNew (Right iid) = (iid, True) idAndNew (Right iid) = (iid, True)
@ -601,13 +607,14 @@ keyListedByActor'
:: Manager :: Manager
-> InstanceId -> InstanceId
-> VerifKeyId -> VerifKeyId
-> FedURI -> Text
-> FedURI -> LocalURI
-> LocalURI
-> Handler (Either String ()) -> Handler (Either String ())
keyListedByActor' manager iid vkid uKey uActor = do keyListedByActor' manager iid vkid host luKey luActor = do
mresult <- do mresult <- do
ments <- runDB $ do ments <- runDB $ do
mrs <- getBy $ UniqueRemoteSharer uActor mrs <- getBy $ UniqueRemoteSharer iid luActor
for mrs $ \ (Entity rsid _) -> for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$> (rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid) getBy (UniqueVerifKeySharedUsage vkid rsid)
@ -619,10 +626,10 @@ keyListedByActor' manager iid vkid uKey uActor = do
then Nothing then Nothing
else Just $ Just rsid else Just $ Just rsid
runExceptT $ for_ mresult $ \ mrsid -> do 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 ExceptT $ runDB $ case mrsid of
Nothing -> do Nothing -> do
rsid <- insert $ RemoteSharer uActor iid uInbox rsid <- insert $ RemoteSharer luActor iid luInbox
insert_ $ VerifKeySharedUsage vkid rsid insert_ $ VerifKeySharedUsage vkid rsid
return $ Right () return $ Right ()
Just rsid -> do Just rsid -> do
@ -635,16 +642,16 @@ keyListedByActor' manager iid vkid uKey uActor = do
data AddVerifKey = AddVerifKey data AddVerifKey = AddVerifKey
{ addvkHost :: Text { addvkHost :: Text
, addvkKeyId :: FedURI , addvkKeyId :: LocalURI
, addvkExpires :: Maybe UTCTime , addvkExpires :: Maybe UTCTime
, addvkKey :: PublicKey , addvkKey :: PublicKey
, addvkActorId :: FedURI , addvkActorId :: LocalURI
, addvkActorInbox :: FedURI , addvkActorInbox :: LocalURI
} }
addSharedKey :: AddVerifKey -> AppDB (Maybe String) addSharedKey :: AddVerifKey -> AppDB (Maybe String)
addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
(iid, rsid, inew) <- instanceAndActor host uActor uInbox (iid, rsid, inew) <- instanceAndActor host luActor luInbox
room <- room <-
case inew of case inew of
Nothing -> pure True Nothing -> pure True
@ -657,7 +664,7 @@ addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do
else return False else return False
if room if room
then do then do
vkid <- insert $ VerifKey uKey iid mexpires key Nothing vkid <- insert $ VerifKey luKey iid mexpires key Nothing
insert_ $ VerifKeySharedUsage vkid rsid insert_ $ VerifKeySharedUsage vkid rsid
return Nothing return Nothing
else return $ Just "We already store 2 keys" 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] (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
addPersonalKey :: AddVerifKey -> AppDB (Maybe String) addPersonalKey :: AddVerifKey -> AppDB (Maybe String)
addPersonalKey (AddVerifKey host uKey mexpires key uActor uInbox) = do addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
(iid, rsid, inew) <- instanceAndActor host uActor uInbox (iid, rsid, inew) <- instanceAndActor host luActor luInbox
room <- room <-
if inew == Just False if inew == Just False
then actorRoom rsid then actorRoom rsid
else pure True else pure True
if room if room
then do then do
insert_ $ VerifKey uKey iid mexpires key (Just rsid) insert_ $ VerifKey luKey iid mexpires key (Just rsid)
return Nothing return Nothing
else return $ Just "We already store 2 keys" else return $ Just "We already store 2 keys"
@ -700,24 +707,24 @@ updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk
updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk
data VerifKeyDetail = VerifKeyDetail data VerifKeyDetail = VerifKeyDetail
{ vkdKeyId :: FedURI { vkdKeyId :: LocalURI
, vkdInboxOrId :: Either FedURI VerifKeyId , vkdInboxOrId :: Either LocalURI VerifKeyId
, vkdKey :: PublicKey , vkdKey :: PublicKey
, vkdExpires :: Maybe UTCTime , vkdExpires :: Maybe UTCTime
, vkdActorId :: FedURI , vkdActorId :: LocalURI
, vkdHost :: Text
, vkdShared :: Bool , vkdShared :: Bool
} }
makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate
makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) = makeVerifKeyUpdate
case iori of host (VerifKeyDetail luKey iori key mexpires luActor shared) =
Left uInbox -> case iori of
let avk = AddVerifKey host uKey mexpires key uActor uInbox Left luInbox ->
in if shared let avk = AddVerifKey host luKey mexpires key luActor luInbox
then VKUAddSharedKey avk in if shared
else VKUAddPersonalKey avk then VKUAddSharedKey avk
Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key else VKUAddPersonalKey avk
Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
instance YesodHttpSig App where instance YesodHttpSig App where
data HttpSigVerResult App = HttpSigVerResult (Either String FedURI) data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
@ -734,28 +741,30 @@ instance YesodHttpSig App where
case algo of case algo of
S.AlgorithmEd25519 -> Right () S.AlgorithmEd25519 -> Right ()
S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" 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 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 signature <- ExceptT . pure $ do
case signature sig of case signature sig of
CryptoPassed s -> Right s CryptoPassed s -> Right s
CryptoFailed e -> Left "Parsing Ed25519 signature failed" CryptoFailed e -> Left "Parsing Ed25519 signature failed"
muActorHeader <- do mluActorHeader <- do
bs <- lookupHeaders hActivityPubActor bs <- lookupHeaders hActivityPubActor
case bs of case bs of
[] -> return Nothing [] -> return Nothing
[b] -> fmap Just . ExceptT . pure $ do [b] -> fmap Just . ExceptT . pure $ do
t <- first displayException $ decodeUtf8' b t <- first displayException $ decodeUtf8' b
u <- parseFedURI t (h, lu) <- f2l <$> parseFedURI t
if furiHost u == furiHost uKey if h == host
then Right () then Right ()
else Left "Key and actor have different hosts" else Left "Key and actor have different hosts"
Right u Right lu
_ -> throwE "Multiple ActivityPub-Actor headers" _ -> throwE "Multiple ActivityPub-Actor headers"
vkd <- do vkd <- do
ments <- lift $ runDB $ 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 for mvk $ \ vk@(Entity _ verifkey) -> do
mremote <- traverse getJust $ verifKeySharer verifkey mremote <- traverse getJust $ verifKeySharer verifkey
return (vk, mremote) return (vk, mremote)
@ -765,30 +774,29 @@ instance YesodHttpSig App where
case mremote of case mremote of
Just remote -> do Just remote -> do
let sharer = remoteSharerIdent remote let sharer = remoteSharerIdent remote
for_ muActorHeader $ \ u -> for_ mluActorHeader $ \ u ->
if sharer == u if sharer == u
then return () then return ()
else throwE "Key's owner doesn't match actor header" else throwE "Key's owner doesn't match actor header"
return (sharer, False) return (sharer, False)
Nothing -> do Nothing -> do
ua <- case muActorHeader of ua <- case mluActorHeader of
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!" Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
Just u -> return u Just u -> return u
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
let iid = verifKeyInstance vk let iid = verifKeyInstance vk
ExceptT $ ExceptT $
keyListedByActor' manager iid vkid uKey ua keyListedByActor' manager iid vkid host luKey ua
return (ua, True) return (ua, True)
return VerifKeyDetail return VerifKeyDetail
{ vkdKeyId = uKey { vkdKeyId = luKey
, vkdInboxOrId = Right vkid , vkdInboxOrId = Right vkid
, vkdKey = verifKeyPublic vk , vkdKey = verifKeyPublic vk
, vkdExpires = verifKeyExpires vk , vkdExpires = verifKeyExpires vk
, vkdActorId = ua , vkdActorId = ua
, vkdHost = furiHost uKey
, vkdShared = s , vkdShared = s
} }
Nothing -> fetched2vkd uKey <$> fetchKey' muActorHeader uKey Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey
let verify' k = verify k input signature let verify' k = verify k input signature
errSig = throwE "Ed25519 sig verification says not valid" errSig = throwE "Ed25519 sig verification says not valid"
errTime = throwE "Key expired" errTime = throwE "Key expired"
@ -804,17 +812,14 @@ instance YesodHttpSig App where
else Just vkd else Just vkd
else if existsInDB else if existsInDB
then do 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 if vkdShared vkd == s
then return () then return ()
else throwE "Key scope changed, we reject that" else throwE "Key scope changed, we reject that"
if vkdShared vkd unless (vkdShared vkd) $
then if h == vkdHost vkd if newActor == vkdActorId vkd
then return () then return ()
else fail "BUG! We re-fetched a key and the host changed" else throwE "Key owner changed, we reject that"
else if newActor == vkdActorId vkd
then return ()
else throwE "Key owner changed, we reject that"
if stillValid newExp if stillValid newExp
then return () then return ()
else errTime else errTime
@ -828,19 +833,18 @@ instance YesodHttpSig App where
then errSig then errSig
else errTime else errTime
for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate host
return $ vkdActorId vkd return $ l2f host $ vkdActorId vkd
where where
fetchKey' mua uk = do fetchKey' h mua uk = do
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
ExceptT $ fetchKey manager (isJust malgo) mua uk ExceptT $ fetchKey manager (isJust malgo) h mua uk
fetched2vkd uk (Fetched k mexp ua uinb h s) = VerifKeyDetail fetched2vkd uk (Fetched k mexp ua uinb s) = VerifKeyDetail
{ vkdKeyId = uk { vkdKeyId = uk
, vkdInboxOrId = Left uinb , vkdInboxOrId = Left uinb
, vkdKey = k , vkdKey = k
, vkdExpires = mexp , vkdExpires = mexp
, vkdActorId = ua , vkdActorId = ua
, vkdHost = h
, vkdShared = s , vkdShared = s
} }

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

@ -31,6 +31,7 @@ import Control.Exception (displayException)
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 (ExceptT (ExceptT), runExceptT)
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)
import Data.Aeson import Data.Aeson
@ -230,7 +231,8 @@ postOutboxR = do
} }
} }
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
minbox <- fetchInboxURI manager to let (host, lto) = f2l to
minbox <- fetchInboxURI manager host lto
for_ minbox $ \ inbox -> do for_ minbox $ \ inbox -> do
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
let (keyID, akey) = let (keyID, akey) =
@ -238,38 +240,30 @@ 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 inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID 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."
defaultLayout $ activityWidget widget enctype defaultLayout $ activityWidget widget enctype
where where
fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI) fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI)
fetchInboxURI manager to = do fetchInboxURI manager h lto = do
mrs <- runDB $ getBy $ UniqueRemoteSharer to mrs <- runDB $ runMaybeT $ do
Entity iid _ <- MaybeT $ getBy $ UniqueInstance h
MaybeT $ getBy $ UniqueRemoteSharer iid lto
case mrs of case mrs of
Nothing -> do Nothing -> do
eres <- httpGetAP manager to eres <- fetchAPID manager actorId h lto
case eres of case eres of
Left (APGetErrorHTTP e) -> do Left s -> do
setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) setMessage $ toHtml $ T.pack s
return Nothing return Nothing
Left (APGetErrorJSON e) -> do Right actor -> do
setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) let inbox = actorInbox actor
return Nothing runDB $ do
Left (APGetErrorContentType e) -> do iid <- either entityKey id <$> insertBy (Instance h)
setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e insert_ $ RemoteSharer lto iid inbox
return Nothing return $ Just inbox
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
Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
@ -278,14 +272,14 @@ getActorKey choose route = do
liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
getsYesod appActorKeys getsYesod appActorKeys
route2uri <- route2uri' <$> getUrlRender route2uri <- route2uri' <$> getUrlRender
let (host, id_) = f2l $ route2uri route
selectRep $ selectRep $
provideAP PublicKey provideAP $ Doc host PublicKey
{ publicKeyId = route2uri route { publicKeyId = id_
, publicKeyExpires = Nothing , publicKeyExpires = Nothing
, publicKeyOwner = route2uri HomeR , publicKeyOwner = OwnerInstance
, publicKeyPem = PEM "PUBLIC KEY" [] actorKey , publicKeyPem = PEM "PUBLIC KEY" [] actorKey
, publicKeyAlgo = Just AlgorithmEd25519 , publicKeyAlgo = Just AlgorithmEd25519
, publicKeyShared = True
} }
getActorKey1R :: Handler TypedContent getActorKey1R :: Handler TypedContent

11
src/Vervis/Handler/Person.hs
View file

@ -132,18 +132,19 @@ getPerson shr person = do
case parseFedURI $ renderUrl route of case parseFedURI $ renderUrl route of
Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e
Right u -> u Right u -> u
me = route2uri $ SharerR shr route2local = snd . f2l . route2uri
(host, me) = f2l $ route2uri $ SharerR shr
selectRep $ do selectRep $ do
provideRep $ do provideRep $ do
secure <- getSecure secure <- getSecure
defaultLayout $(widgetFile "person") defaultLayout $(widgetFile "person")
provideAP Actor provideAP $ Doc host Actor
{ actorId = me { actorId = me
, actorType = ActorTypePerson , actorType = ActorTypePerson
, actorUsername = shr2text shr , actorUsername = shr2text shr
, actorInbox = route2uri InboxR , actorInbox = route2local InboxR
, actorPublicKeys = PublicKeySet , actorPublicKeys = PublicKeySet
{ publicKey1 = Left $ route2uri ActorKey1R { publicKey1 = Left $ route2local ActorKey1R
, publicKey2 = Just $ Left $ route2uri ActorKey2R , publicKey2 = Just $ Left $ route2local ActorKey2R
} }
} }

2
src/Vervis/Model.hs
View file

@ -28,7 +28,7 @@ import Yesod.Auth.Account (PersistUserCredentials (..))
import Database.Persist.EmailAddress import Database.Persist.EmailAddress
import Database.Persist.Graph.Class import Database.Persist.Graph.Class
import Network.FedURI (FedURI) import Network.FedURI (FedURI, LocalURI)
import Vervis.Model.Group import Vervis.Model.Group
import Vervis.Model.Ident import Vervis.Model.Ident

367
src/Web/ActivityPub.hs
View file

@ -14,12 +14,21 @@
-} -}
module Web.ActivityPub 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' -- ActivityPub actor document including a public key, with a 'FromJSON'
-- instance for fetching and a 'ToJSON' instance for publishing. -- instance for fetching and a 'ToJSON' instance for publishing.
ActorType (..) , ActorType (..)
, Algorithm (..) , Algorithm (..)
, Owner (..)
, PublicKey (..) , PublicKey (..)
, PublicKeySet (..) , PublicKeySet (..)
, Actor (..) , Actor (..)
@ -36,6 +45,7 @@ module Web.ActivityPub
, httpGetAP , httpGetAP
, httpPostAP , httpPostAP
, Fetched (..) , Fetched (..)
, fetchAPID
, keyListedByActor , keyListedByActor
, fetchKey , fetchKey
) )
@ -45,24 +55,26 @@ import Prelude
import Control.Applicative ((<|>), optional) import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, displayException, try) import Control.Exception (Exception, displayException, try)
import Control.Monad (unless, (<=<)) import Control.Monad (when, unless, (<=<))
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (Writer) import Control.Monad.Trans.Writer (Writer)
import Crypto.Error (CryptoFailable (..)) import Crypto.Error (CryptoFailable (..))
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (Parser) import Data.Aeson.Encoding (pair)
import Data.Bifunctor (bimap, first) import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
import Data.Bifunctor
import Data.Bitraversable (bitraverse) import Data.Bitraversable (bitraverse)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Proxy
import Data.PEM import Data.PEM
import Data.Semigroup (Endo) import Data.Semigroup (Endo)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock (UTCTime) 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.Conduit.ActivityPub (httpAPEither)
import Network.HTTP.Client.Signature (signRequest) import Network.HTTP.Client.Signature (signRequest)
import Network.HTTP.Signature (KeyId, Signature) import Network.HTTP.Signature (KeyId, Signature)
@ -81,14 +93,58 @@ import Network.FedURI
import Data.Aeson.Local import Data.Aeson.Local
proxy :: a -> Proxy a
proxy _ = Proxy
as2context :: Text as2context :: Text
as2context = "https://www.w3.org/ns/activitystreams" as2context = "https://www.w3.org/ns/activitystreams"
actorContext :: Value secContext :: Text
actorContext = Array $ V.fromList secContext = "https://w3id.org/security/v1"
[ String as2context
, String "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 data ActorType = ActorTypePerson | ActorTypeOther Text
@ -120,32 +176,44 @@ instance ToJSON Algorithm where
AlgorithmEd25519 -> frg <> "ed25519" AlgorithmEd25519 -> frg <> "ed25519"
AlgorithmOther t -> t AlgorithmOther t -> t
data Owner = OwnerInstance | OwnerActor LocalURI
ownerShared :: Owner -> Bool
ownerShared OwnerInstance = True
ownerShared (OwnerActor _) = False
data PublicKey = PublicKey data PublicKey = PublicKey
{ publicKeyId :: FedURI { publicKeyId :: LocalURI
, publicKeyExpires :: Maybe UTCTime , publicKeyExpires :: Maybe UTCTime
, publicKeyOwner :: FedURI , publicKeyOwner :: Owner
, publicKeyPem :: PEM , publicKeyPem :: PEM
, publicKeyAlgo :: Maybe Algorithm , publicKeyAlgo :: Maybe Algorithm
, publicKeyShared :: Bool
} }
instance FromJSON PublicKey where instance ActivityPub PublicKey where
parseJSON = withObject "PublicKey" $ \ o -> do jsonldContext _ = ContextPKey
parseObject o = do
mtyp <- optional $ o .: "@type" <|> o .: "type" mtyp <- optional $ o .: "@type" <|> o .: "type"
case mtyp of for_ mtyp $ \ t ->
Nothing -> return () when (t /= ("Key" :: Text)) $
Just t -> fail "PublicKey @type isn't Key"
if t == ("Key" :: Text) (host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
then return () shared <- o .: (frg <> "isShared") .!= False
else fail "PublicKey @type isn't Key" fmap (host,) $
PublicKey PublicKey id_
<$> o .: "id" <$> o .:? "expires"
<*> o .:? "expires" <*> (mkOwner shared =<< withHost host o "owner")
<*> o .: "owner" <*> (parsePEM =<< o .: "publicKeyPem")
<*> (parsePEM =<< o .: "publicKeyPem") <*> o .:? (frg <> "algorithm")
<*> o .:? (frg <> "algorithm")
<*> o .:? (frg <> "shared") .!= False
where 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 = parsePEM t =
case pemParseBS $ encodeUtf8 t of case pemParseBS $ encodeUtf8 t of
Left e -> fail $ "PEM parsing failed: " ++ e Left e -> fail $ "PEM parsing failed: " ++ e
@ -154,73 +222,84 @@ instance FromJSON PublicKey where
[] -> fail "Empty PEM" [] -> fail "Empty PEM"
[x] -> pure x [x] -> pure x
_ -> fail "Multiple PEM sections" _ -> fail "Multiple PEM sections"
toSeries host (PublicKey id_ mexpires owner pem malgo)
instance ToJSON PublicKey where = "@id" .= l2f host id_
toJSON = error "toJSON PublicKey" <> "expires" .=? mexpires
toEncoding (PublicKey id_ mexpires owner pem malgo shared) = <> "owner" .= mkOwner host owner
pairs <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
$ "id" .= id_ <> (frg <> "algorithm") .=? malgo
<> "expires" .=? mexpires <> (frg <> "isShared") .= ownerShared owner
<> "owner" .= owner where
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem) mkOwner h OwnerInstance = FedURI h "" ""
<> (frg <> "algorithm") .=? malgo mkOwner h (OwnerActor lu) = l2f h lu
<> (frg <> "shared") .= shared
data PublicKeySet = PublicKeySet data PublicKeySet = PublicKeySet
{ publicKey1 :: Either FedURI PublicKey { publicKey1 :: Either LocalURI PublicKey
, publicKey2 :: Maybe (Either FedURI PublicKey) , publicKey2 :: Maybe (Either LocalURI PublicKey)
} }
instance FromJSON PublicKeySet where parsePublicKeySet :: Value -> Parser (Text, PublicKeySet)
parseJSON v = parsePublicKeySet v =
case v of case v of
Array a -> Array a ->
case V.toList a of case V.toList a of
[] -> fail "No public keys" [] -> fail "No public keys"
[k1] -> PublicKeySet <$> parseKey k1 <*> pure Nothing [k1] -> second (flip PublicKeySet Nothing) <$> parseKey k1
[k1, k2] -> PublicKeySet <$> parseKey k1 <*> (Just <$> parseKey k2) [k1, k2] -> do
_ -> fail "More than 2 public keys isn't supported" (h, e1) <- parseKey k1
_ -> PublicKeySet <$> parseKey v <*> pure Nothing e2 <- withHost h $ parseKey k2
where return (h, PublicKeySet e1 $ Just e2)
parseKey = fmap toEither . parseJSON _ -> 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 encodePublicKeySet :: Text -> PublicKeySet -> Encoding
toJSON = error "toJSON PublicKeySet" encodePublicKeySet host (PublicKeySet k1 mk2) =
toEncoding (PublicKeySet k1 mk2) = case mk2 of
case mk2 of Nothing -> renderKey k1
Nothing -> toEncoding $ renderKey k1 Just k2 -> listEncoding renderKey [k1, k2]
Just k2 -> toEncodingList [renderKey k1, renderKey k2] where
where renderKey (Left lu) = toEncoding $ l2f host lu
renderKey = fromEither renderKey (Right pk) = pairs $ toSeries host pk
data Actor = Actor data Actor = Actor
{ actorId :: FedURI { actorId :: LocalURI
, actorType :: ActorType , actorType :: ActorType
, actorUsername :: Text , actorUsername :: Text
, actorInbox :: FedURI , actorInbox :: LocalURI
, actorPublicKeys :: PublicKeySet , actorPublicKeys :: PublicKeySet
} }
instance FromJSON Actor where instance ActivityPub Actor where
parseJSON = withObject "Actor" $ \ o -> jsonldContext _ = ContextActor
Actor parseObject o = do
<$> o .: "id" (host, id_) <- f2l <$> o .: "id"
<*> o .: "type" fmap (host,) $
<*> o .: "preferredUsername" Actor id_
<*> o .: "inbox" <$> o .: "type"
<*> o .: "publicKey" <*> o .: "preferredUsername"
<*> withHost host (f2l <$> o .: "inbox")
instance ToJSON Actor where <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
toJSON = error "toJSON Actor" where
toEncoding (Actor id_ typ username inbox pkeys) = withHost h a = do
pairs (h', v) <- a
$ "@context" .= actorContext if h == h'
<> "id" .= id_ then return v
<> "type" .= typ else fail "URI host mismatch"
<> "preferredUsername" .= username toSeries host (Actor id_ typ username inbox pkeys)
<> "inbox" .= inbox = "id" .= l2f host id_
<> "publicKey" .= pkeys <> "type" .= typ
<> "preferredUsername" .= username
<> "inbox" .= l2f host inbox
<> "publicKey" `pair` encodePublicKeySet host pkeys
data Note = Note data Note = Note
{ noteId :: FedURI { noteId :: FedURI
, noteAttrib :: FedURI , noteAttrib :: FedURI
@ -390,12 +469,10 @@ data Fetched = Fetched
-- ^ The Ed25519 public key corresponding to the URI we requested. -- ^ The Ed25519 public key corresponding to the URI we requested.
, fetchedKeyExpires :: Maybe UTCTime , fetchedKeyExpires :: Maybe UTCTime
-- ^ Optional expiration time declared for the key we received. -- ^ 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. -- ^ 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. -- ^ 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 , fetchedKeyShared :: Bool
-- ^ Whether the key we received is shared. A shared key can sign -- ^ 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 -- requests for any actor on the same instance, while a personal key is
@ -405,16 +482,50 @@ data Fetched = Fetched
-- we received. -- 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 -- | 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 -- 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 -- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an
-- error message. -- error message.
keyListedByActor :: MonadIO m => Manager -> FedURI -> FedURI -> m (Either String Actor) keyListedByActor :: MonadIO m => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor)
keyListedByActor manager uKey uActor = runExceptT $ do keyListedByActor manager host luKey luActor = runExceptT $ do
let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a actor <- ExceptT $ fetchAPID manager actorId host luActor
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u if keyUriListed luKey actor
actor <- fetch uActor
if keyUriListed uKey actor
then return actor then return actor
else throwE "Actor publicKey has no URI matching pkey @id" else throwE "Actor publicKey has no URI matching pkey @id"
where where
@ -428,63 +539,54 @@ fetchKey
:: MonadIO m :: MonadIO m
=> Manager => Manager
-> Bool -> Bool
-> Maybe FedURI -> Text
-> FedURI -> Maybe LocalURI
-> LocalURI
-> m (Either String Fetched) -> m (Either String Fetched)
fetchKey manager sigAlgo muActor uKey = runExceptT $ do fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a obj <- fetchAPIDOrH manager publicKeyId host luKey
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
obj <- fetch uKey
let inztance = f2i uKey
(actor, pkey) <- (actor, pkey) <-
case obj of case obj of
Left' pkey -> do Left pkey -> do
if publicKeyId pkey == uKey luActor <-
then return () case publicKeyOwner pkey of
else throwE "Public key's ID doesn't match the keyid URI" OwnerInstance ->
if furiHost (publicKeyOwner pkey) == furiHost uKey case mluActor of
then return () Nothing -> throwE "Key is shared but actor header not specified!"
else throwE "Actor and key on different domains, we reject" Just u -> return u
uActor <- OwnerActor owner -> do
if publicKeyShared pkey for_ mluActor $ \ lu ->
then case muActor of if owner == lu
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
then return () then return ()
else throwE "Key's owner doesn't match actor header" else throwE "Key's owner doesn't match actor header"
return owner return owner
actor <- ExceptT $ keyListedByActor manager uKey uActor actor <- ExceptT $ keyListedByActor manager host luKey luActor
return (actor, pkey) return (actor, pkey)
Right' actor -> do Right actor -> do
if actorId actor == uKey { furiFragment = "" } if actorId actor == luKey { luriFragment = "" }
then return () then return ()
else throwE "Actor ID doesn't match the keyid URI we fetched" else throwE "Actor ID doesn't match the keyid URI we fetched"
for_ muActor $ \ u -> for_ mluActor $ \ lu ->
if actorId actor == u if actorId actor == lu
then return () then return ()
else throwE "Key's owner doesn't match actor header" else throwE "Key's owner doesn't match actor header"
let PublicKeySet k1 mk2 = actorPublicKeys actor let PublicKeySet k1 mk2 = actorPublicKeys actor
match (Left _) = Nothing match (Left _) = Nothing
match (Right pk) = match (Right pk) =
if publicKeyId pk == uKey if publicKeyId pk == luKey
then Just pk then Just pk
else Nothing else Nothing
case match k1 <|> (match =<< mk2) of case match k1 <|> (match =<< mk2) of
Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
Just pk -> Just pk ->
if publicKeyShared pk case publicKeyOwner pk of
then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" OwnerInstance -> 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) OwnerActor _ -> return (actor, pk)
ExceptT . pure $ do ExceptT . pure $ do
if publicKeyShared pkey case publicKeyOwner pkey of
then if publicKeyOwner pkey == i2f inztance OwnerInstance -> Right ()
then Right () OwnerActor owner ->
else Left "Key is shared but its owner isn't the top-level instance URI" if owner == actorId actor
else if publicKeyOwner pkey == actorId actor
then Right () then Right ()
else Left "Actor's publicKey's owner doesn't match the actor's ID" else Left "Actor's publicKey's owner doesn't match the actor's ID"
case publicKeyAlgo pkey of case publicKeyAlgo pkey of
@ -507,7 +609,6 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
, fetchedKeyExpires = publicKeyExpires pkey , fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = actorId actor , fetchedActorId = actorId actor
, fetchedActorInbox = actorInbox actor , fetchedActorInbox = actorInbox actor
, fetchedHost = furiHost uKey , fetchedKeyShared = ownerShared $ publicKeyOwner pkey
, fetchedKeyShared = publicKeyShared pkey
} }
CryptoFailed _ -> Left "Parsing Ed25519 public key failed" CryptoFailed _ -> Left "Parsing Ed25519 public key failed"