mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-07 20:56:47 +09:00
df01560ea6
This patch includes some ugliness and commented out code. Sorry for that. I'll clean it up soon. Basically there's a TVar holding a Vector of at most 10 AP activities. You can freely POST stuff to /inbox, and then GET /inbox and see what you posted, or an error description saying why your activity was rejected.
146 lines
4.3 KiB
Haskell
146 lines
4.3 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.ActivityPub
|
|
( ActorType (..)
|
|
, Algorithm (..)
|
|
, PublicKey (..)
|
|
, Actor (..)
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Data.Aeson
|
|
import Data.Aeson.Types (Parser)
|
|
import Data.PEM
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
import Network.URI
|
|
|
|
import qualified Data.Text as T (unpack)
|
|
import qualified Data.Vector as V (fromList)
|
|
|
|
frg :: Text
|
|
frg = "https://forgefed.angeley.es/ns#"
|
|
|
|
context :: Value
|
|
context = Array $ V.fromList
|
|
[ String "https://www.w3.org/ns/activitystreams"
|
|
, String "https://w3id.org/security/v1"
|
|
]
|
|
|
|
parseURI' :: Text -> Parser URI
|
|
parseURI' t =
|
|
case parseURI $ T.unpack t of
|
|
Nothing -> fail "Invalid absolute URI"
|
|
Just u ->
|
|
if uriScheme u == "https:"
|
|
then return u
|
|
else fail "URI scheme isn't https"
|
|
|
|
renderURI :: URI -> String
|
|
renderURI u = uriToString id u ""
|
|
|
|
data ActorType = ActorTypePerson | ActorTypeOther Text
|
|
|
|
instance FromJSON ActorType where
|
|
parseJSON = withText "ActorType" $ \ t ->
|
|
pure $ case t of
|
|
"Person" -> ActorTypePerson
|
|
_ -> ActorTypeOther t
|
|
|
|
instance ToJSON ActorType where
|
|
toJSON = error "toJSON ActorType"
|
|
toEncoding at =
|
|
toEncoding $ case at of
|
|
ActorTypePerson -> "Person"
|
|
ActorTypeOther t -> t
|
|
|
|
data Algorithm = AlgorithmEd25519 | AlgorithmOther Text
|
|
|
|
instance FromJSON Algorithm where
|
|
parseJSON = withText "Algorithm" $ \ t ->
|
|
pure $ if t == frg <> "ed25519"
|
|
then AlgorithmEd25519
|
|
else AlgorithmOther t
|
|
|
|
instance ToJSON Algorithm where
|
|
toJSON = error "toJSON Algorithm"
|
|
toEncoding algo =
|
|
toEncoding $ case algo of
|
|
AlgorithmEd25519 -> frg <> "ed25519"
|
|
AlgorithmOther t -> t
|
|
|
|
data PublicKey = PublicKey
|
|
{ publicKeyId :: URI
|
|
, publicKeyOwner :: URI
|
|
, publicKeyPem :: PEM
|
|
, publicKeyAlgo :: Maybe Algorithm
|
|
}
|
|
|
|
instance FromJSON PublicKey where
|
|
parseJSON = withObject "PublicKey" $ \ o ->
|
|
PublicKey
|
|
<$> (parseURI' =<< o .: "id")
|
|
<*> (parseURI' =<< o .: "owner")
|
|
<*> (parsePEM =<< o .: "publicKeyPem")
|
|
<*> o .:? (frg <> "algorithm")
|
|
where
|
|
parsePEM t =
|
|
case pemParseBS $ encodeUtf8 t of
|
|
Left e -> fail $ "PEM parsing failed: " ++ e
|
|
Right xs ->
|
|
case xs of
|
|
[] -> fail "Empty PEM"
|
|
[x] -> pure x
|
|
_ -> fail "Multiple PEM sections"
|
|
|
|
instance ToJSON PublicKey where
|
|
toJSON = error "toJSON PublicKey"
|
|
toEncoding (PublicKey id_ owner pem malgo) =
|
|
pairs
|
|
$ "id" .= renderURI id_
|
|
<> "owner" .= renderURI owner
|
|
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
|
<> maybe mempty ((frg <> "algorithm") .=) malgo
|
|
|
|
data Actor = Actor
|
|
{ actorId :: URI
|
|
, actorType :: ActorType
|
|
, actorUsername :: Text
|
|
, actorInbox :: URI
|
|
, actorPublicKey :: PublicKey
|
|
}
|
|
|
|
instance FromJSON Actor where
|
|
parseJSON = withObject "Actor" $ \ o ->
|
|
Actor
|
|
<$> (parseURI' =<< o .: "id")
|
|
<*> o .: "type"
|
|
<*> o .: "preferredUsername"
|
|
<*> (parseURI' =<< o .: "inbox")
|
|
<*> o .: "publicKey"
|
|
|
|
instance ToJSON Actor where
|
|
toJSON = error "toJSON Actor"
|
|
toEncoding (Actor id_ typ username inbox pkey) =
|
|
pairs
|
|
$ "@context" .= context
|
|
<> "id" .= renderURI id_
|
|
<> "type" .= typ
|
|
<> "preferredUsername" .= username
|
|
<> "inbox" .= renderURI inbox
|
|
<> "publicKey" .= pkey
|