Add LocalURI type for recording shared URI host
This commit is contained in:
parent
aefb2aaee7
commit
d3e14b3edf
8 changed files with 379 additions and 242 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
|
||||||
case mrs of
|
|
||||||
Nothing -> do
|
|
||||||
(iid, inew) <- idAndNew <$> insertBy (Instance host)
|
(iid, inew) <- idAndNew <$> insertBy (Instance host)
|
||||||
rsid <- insert $ RemoteSharer uActor iid uInbox
|
let rs = RemoteSharer luActor iid luInbox
|
||||||
return (iid, rsid, if inew then Nothing else Just True)
|
if inew
|
||||||
Just (Entity rsid rs) ->
|
then do
|
||||||
return (remoteSharerInstance rs, rsid, Just False)
|
rsid <- insert rs
|
||||||
|
return (iid, rsid, Nothing)
|
||||||
|
else do
|
||||||
|
(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,20 +707,20 @@ 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
|
||||||
|
host (VerifKeyDetail luKey iori key mexpires luActor shared) =
|
||||||
case iori of
|
case iori of
|
||||||
Left uInbox ->
|
Left luInbox ->
|
||||||
let avk = AddVerifKey host uKey mexpires key uActor uInbox
|
let avk = AddVerifKey host luKey mexpires key luActor luInbox
|
||||||
in if shared
|
in if shared
|
||||||
then VKUAddSharedKey avk
|
then VKUAddSharedKey avk
|
||||||
else VKUAddPersonalKey avk
|
else VKUAddPersonalKey avk
|
||||||
|
@ -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,15 +812,12 @@ 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 ()
|
|
||||||
else fail "BUG! We re-fetched a key and the host changed"
|
|
||||||
else if newActor == vkdActorId vkd
|
|
||||||
then return ()
|
then return ()
|
||||||
else throwE "Key owner changed, we reject that"
|
else throwE "Key owner changed, we reject that"
|
||||||
if stillValid newExp
|
if stillValid newExp
|
||||||
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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,37 +240,29 @@ 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)
|
|
||||||
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
|
let inbox = actorInbox actor
|
||||||
runDB $ do
|
runDB $ do
|
||||||
iid <- either entityKey id <$> insertBy (Instance $ furiHost to)
|
iid <- either entityKey id <$> insertBy (Instance h)
|
||||||
insert_ $ RemoteSharer to iid inbox
|
insert_ $ RemoteSharer lto iid inbox
|
||||||
return $ Just inbox
|
return $ Just inbox
|
||||||
Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
|
Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
|
||||||
toEncoding (PublicKey id_ mexpires owner pem malgo shared) =
|
|
||||||
pairs
|
|
||||||
$ "id" .= id_
|
|
||||||
<> "expires" .=? mexpires
|
<> "expires" .=? mexpires
|
||||||
<> "owner" .= owner
|
<> "owner" .= mkOwner host owner
|
||||||
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
||||||
<> (frg <> "algorithm") .=? malgo
|
<> (frg <> "algorithm") .=? malgo
|
||||||
<> (frg <> "shared") .= shared
|
<> (frg <> "isShared") .= ownerShared owner
|
||||||
|
where
|
||||||
|
mkOwner h OwnerInstance = FedURI h "" ""
|
||||||
|
mkOwner h (OwnerActor lu) = l2f h lu
|
||||||
|
|
||||||
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
|
||||||
|
(h, e1) <- parseKey k1
|
||||||
|
e2 <- withHost h $ parseKey k2
|
||||||
|
return (h, PublicKeySet e1 $ Just e2)
|
||||||
_ -> fail "More than 2 public keys isn't supported"
|
_ -> fail "More than 2 public keys isn't supported"
|
||||||
_ -> PublicKeySet <$> parseKey v <*> pure Nothing
|
_ -> second (flip PublicKeySet Nothing) <$> parseKey v
|
||||||
where
|
where
|
||||||
parseKey = fmap toEither . parseJSON
|
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 -> toEncoding $ renderKey k1
|
Nothing -> renderKey k1
|
||||||
Just k2 -> toEncodingList [renderKey k1, renderKey k2]
|
Just k2 -> listEncoding renderKey [k1, k2]
|
||||||
where
|
where
|
||||||
renderKey = fromEither
|
renderKey (Left lu) = toEncoding $ l2f host lu
|
||||||
|
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,) $
|
||||||
|
Actor id_
|
||||||
|
<$> o .: "type"
|
||||||
<*> o .: "preferredUsername"
|
<*> o .: "preferredUsername"
|
||||||
<*> o .: "inbox"
|
<*> withHost host (f2l <$> o .: "inbox")
|
||||||
<*> o .: "publicKey"
|
<*> withHost host (parsePublicKeySet =<< o .: "publicKey")
|
||||||
|
where
|
||||||
instance ToJSON Actor where
|
withHost h a = do
|
||||||
toJSON = error "toJSON Actor"
|
(h', v) <- a
|
||||||
toEncoding (Actor id_ typ username inbox pkeys) =
|
if h == h'
|
||||||
pairs
|
then return v
|
||||||
$ "@context" .= actorContext
|
else fail "URI host mismatch"
|
||||||
<> "id" .= id_
|
toSeries host (Actor id_ typ username inbox pkeys)
|
||||||
|
= "id" .= l2f host id_
|
||||||
<> "type" .= typ
|
<> "type" .= typ
|
||||||
<> "preferredUsername" .= username
|
<> "preferredUsername" .= username
|
||||||
<> "inbox" .= inbox
|
<> "inbox" .= l2f host inbox
|
||||||
<> "publicKey" .= pkeys
|
<> "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 ()
|
|
||||||
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!"
|
Nothing -> throwE "Key is shared but actor header not specified!"
|
||||||
Just u -> return u
|
Just u -> return u
|
||||||
else do
|
OwnerActor owner -> do
|
||||||
let owner = publicKeyOwner pkey
|
for_ mluActor $ \ lu ->
|
||||||
for_ muActor $ \ u ->
|
if owner == lu
|
||||||
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"
|
||||||
|
|
Loading…
Reference in a new issue