forge/Vervis
1
0
Fork 0
Code Pull requests 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
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

4
migrations/2019_02_03_verifkey.model
View file

@ -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

41
src/Network/FedURI.hs
View file

@ -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)

136
src/Vervis/Foundation.hs
View file

@ -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
}

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.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

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

@ -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
}
}

2
src/Vervis/Model.hs
View file

@ -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

367
src/Web/ActivityPub.hs
View file

@ -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"