Tools for type-level-property-powered ForgeFed parsing-serializing

src/Web/ActivityPub.hs

@@ -15,6 +15,8 @@
  -}
 
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
 
 module Web.ActivityPub
     ( -- * Type-safe manipulation tools
@@ -142,6 +144,103 @@ module Web.ActivityPub
     , fetchKnownSharedKey
 
     , Obj (..)
+
+    , Property (..)
+
+    {-
+    , Id_
+    , Type_
+
+    , Subject_
+    , Relationship_
+    , Actor_
+    , AttributedTo_
+    , Attachment_
+    , Bcc_
+    , Bto_
+    , Cc_
+    , Context_
+    , Current_
+    , First_
+    , Generator_
+    , Icon_
+    , Image_
+    , InReplyTo_
+    , Items_
+    , Instrument_
+    , OrderedItems_
+    , Last_
+    , Location_
+    , Next_
+    , Object_
+    , OneOf_
+    , AnyOf_
+    , Closed_
+    , Origin_
+    , Accuracy_
+    , Prev_
+    , Preview_
+    , Provider_
+    , Replies_
+    , Result_
+    , Audience_
+    , PartOf_
+    , Tag_
+    , Tags_
+    , Target_
+    , To_
+    , Url_
+    , Altitude_
+    , Content_
+    , ContentMap_
+    , Name_
+    , NameMap_
+    , Duration_
+    , EndTime_
+    , Height_
+    , Href_
+    , Hreflang_
+    , Latitude_
+    , Longitude_
+    , MediaType_
+    , Published_
+    , Radius_
+    , Rating_
+    , Rel_
+    , StartIndex_
+    , StartTime_
+    , Summary_
+    , SummaryMap_
+    , TotalItems_
+    , Units_
+    , Updated_
+    , Width_
+    , Describes_
+    , FormerType_
+    , Deleted_
+
+    , Endpoints_
+    , Following_
+    , Followers_
+    , Inbox_
+    , Liked_
+    , Shares_
+    , Likes_
+    , OauthAuthorizationEndpoint_
+    , OauthTokenEndpoint_
+    , Outbox_
+    , PreferredUsername_
+    , ProvideClientKey_
+    , ProxyUrl_
+    , SharedInbox_
+    , SignClientKey_
+    , Source_
+    , Streams_
+    , UploadMedia_
+    -}
+
+    , req
+    , opt
     )
 where
 
@@ -161,6 +260,7 @@ import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Char
 import Data.Foldable (for_)
+import Data.Kind
 import Data.List
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Proxy
@@ -169,6 +269,7 @@ import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
 import Data.Time.Clock
 import Data.Traversable
+import GHC.TypeLits
 import Network.HTTP.Client hiding (Proxy, proxy)
 import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
 import Network.HTTP.Simple (JSONException)
@@ -179,6 +280,7 @@ import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
 import Network.HTTP.Client.Signature
+import Web.ActivityPub.Internal
 
 import qualified Data.Attoparsec.ByteString as A
 import qualified Data.ByteArray as BA

src/Web/ActivityPub/Internal.hs

@@ -0,0 +1,405 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2024 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/>.
+ -}
+
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+-- I created this module for the type-level properties, because they
+-- require the AllowAmbiguousTypes extension.
+module Web.ActivityPub.Internal
+    ( Property (..)
+
+    {-
+    , Id_
+    , Type_
+
+    , Subject_
+    , Relationship_
+    , Actor_
+    , AttributedTo_
+    , Attachment_
+    , Bcc_
+    , Bto_
+    , Cc_
+    , Context_
+    , Current_
+    , First_
+    , Generator_
+    , Icon_
+    , Image_
+    , InReplyTo_
+    , Items_
+    , Instrument_
+    , OrderedItems_
+    , Last_
+    , Location_
+    , Next_
+    , Object_
+    , OneOf_
+    , AnyOf_
+    , Closed_
+    , Origin_
+    , Accuracy_
+    , Prev_
+    , Preview_
+    , Provider_
+    , Replies_
+    , Result_
+    , Audience_
+    , PartOf_
+    , Tag_
+    , Tags_
+    , Target_
+    , To_
+    , Url_
+    , Altitude_
+    , Content_
+    , ContentMap_
+    , Name_
+    , NameMap_
+    , Duration_
+    , EndTime_
+    , Height_
+    , Href_
+    , Hreflang_
+    , Latitude_
+    , Longitude_
+    , MediaType_
+    , Published_
+    , Radius_
+    , Rating_
+    , Rel_
+    , StartIndex_
+    , StartTime_
+    , Summary_
+    , SummaryMap_
+    , TotalItems_
+    , Units_
+    , Updated_
+    , Width_
+    , Describes_
+    , FormerType_
+    , Deleted_
+
+    , Endpoints_
+    , Following_
+    , Followers_
+    , Inbox_
+    , Liked_
+    , Shares_
+    , Likes_
+    , OauthAuthorizationEndpoint_
+    , OauthTokenEndpoint_
+    , Outbox_
+    , PreferredUsername_
+    , ProvideClientKey_
+    , ProxyUrl_
+    , SharedInbox_
+    , SignClientKey_
+    , Source_
+    , Streams_
+    , UploadMedia_
+    -}
+
+    , req
+    , opt
+    )
+where
+
+import Control.Applicative ((<|>), optional)
+import Control.Exception (Exception, displayException, try)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Writer (Writer)
+import Crypto.Hash hiding (Context)
+import Data.Aeson
+import Data.Aeson.Encoding (pair)
+import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Char
+import Data.Foldable (for_)
+import Data.Kind
+import Data.List
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Proxy
+import Data.Semigroup (Endo, First (..))
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
+import Data.Time.Clock
+import Data.Traversable
+import GHC.TypeLits
+import Network.HTTP.Client hiding (Proxy, proxy)
+import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
+import Network.HTTP.Simple (JSONException)
+import Network.HTTP.Types.Header (HeaderName, hContentType)
+import Text.Email.Parser (EmailAddress)
+import Text.Read (readMaybe)
+import Yesod.Core.Content (ContentType)
+import Yesod.Core.Handler (ProvidedRep, provideRepType)
+
+import Network.HTTP.Client.Signature
+
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base58 as B58
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.HashMap.Strict as M
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Vector as V
+import qualified Network.HTTP.Signature as S
+import qualified Text.Email.Parser as E
+
+import Crypto.PublicVerifKey
+import Development.PatchMediaType
+import Development.PatchMediaType.JSON
+import Network.FedURI
+import Network.HTTP.Digest
+import Web.Text
+
+import Data.Aeson.Local
+
+data Property
+
+    -- Keywords
+
+    = Id_
+    | Type_
+
+    -- ActivityStreams2
+
+    | Subject_
+    | Relationship_
+    | Actor_
+    | AttributedTo_
+    | Attachment_
+    | Bcc_
+    | Bto_
+    | Cc_
+    | Context_
+    | Current_
+    | First_
+    | Generator_
+    | Icon_
+    | Image_
+    | InReplyTo_
+    | Items_
+    | Instrument_
+    | OrderedItems_
+    | Last_
+    | Location_
+    | Next_
+    | Object_
+    | OneOf_
+    | AnyOf_
+    | Closed_
+    | Origin_
+    | Accuracy_
+    | Prev_
+    | Preview_
+    | Provider_
+    | Replies_
+    | Result_
+    | Audience_
+    | PartOf_
+    | Tag_
+    | Tags_
+    | Target_
+    | To_
+    | Url_
+    | Altitude_
+    | Content_
+    | ContentMap_
+    | Name_
+    | NameMap_
+    | Duration_
+    | EndTime_
+    | Height_
+    | Href_
+    | Hreflang_
+    | Latitude_
+    | Longitude_
+    | MediaType_
+    | Published_
+    | Radius_
+    | Rating_
+    | Rel_
+    | StartIndex_
+    | StartTime_
+    | Summary_
+    | SummaryMap_
+    | TotalItems_
+    | Units_
+    | Updated_
+    | Width_
+    | Describes_
+    | FormerType_
+    | Deleted_
+
+    -- ActivityPub
+
+    | Endpoints_
+    | Following_
+    | Followers_
+    | Inbox_
+    | Liked_
+    | Shares_
+    | Likes_
+    | OauthAuthorizationEndpoint_
+    | OauthTokenEndpoint_
+    | Outbox_
+    | PreferredUsername_
+    | ProvideClientKey_
+    | ProxyUrl_
+    | SharedInbox_
+    | SignClientKey_
+    | Source_
+    | Streams_
+    | UploadMedia_
+
+type PropertySymbol :: Property -> Symbol
+type family PropertySymbol p where
+
+    -- Keywords
+
+    PropertySymbol 'Id_ = "id"
+    PropertySymbol 'Type_ = "type"
+
+    -- ActivityStreams2
+
+    PropertySymbol 'Subject_ = "subject"
+    PropertySymbol 'Relationship_ = "relationship"
+    PropertySymbol 'Actor_ = "actor"
+    PropertySymbol 'AttributedTo_ = "attributedTo"
+    PropertySymbol 'Attachment_ = "attachment"
+    PropertySymbol 'Bcc_ = "bcc"
+    PropertySymbol 'Bto_ = "bto"
+    PropertySymbol 'Cc_ = "cc"
+    PropertySymbol 'Context_ = "context"
+    PropertySymbol 'Current_ = "current"
+    PropertySymbol 'First_ = "first"
+    PropertySymbol 'Generator_ = "generator"
+    PropertySymbol 'Icon_ = "icon"
+    PropertySymbol 'Image_ = "image"
+    PropertySymbol 'InReplyTo_ = "inReplyTo"
+    PropertySymbol 'Items_ = "items"
+    PropertySymbol 'Instrument_ = "instrument"
+    PropertySymbol 'OrderedItems_ = "orderedItems"
+    PropertySymbol 'Last_ = "last"
+    PropertySymbol 'Location_ = "location"
+    PropertySymbol 'Next_ = "next"
+    PropertySymbol 'Object_ = "object"
+    PropertySymbol 'OneOf_ = "oneOf"
+    PropertySymbol 'AnyOf_ = "anyOf"
+    PropertySymbol 'Closed_ = "closed"
+    PropertySymbol 'Origin_ = "origin"
+    PropertySymbol 'Accuracy_ = "accuracy"
+    PropertySymbol 'Prev_ = "prev"
+    PropertySymbol 'Preview_ = "preview"
+    PropertySymbol 'Provider_ = "provider"
+    PropertySymbol 'Replies_ = "replies"
+    PropertySymbol 'Result_ = "result"
+    PropertySymbol 'Audience_ = "audience"
+    PropertySymbol 'PartOf_ = "partOf"
+    PropertySymbol 'Tag_ = "tag"
+    PropertySymbol 'Tags_ = "tags"
+    PropertySymbol 'Target_ = "target"
+    PropertySymbol 'To_ = "to"
+    PropertySymbol 'Url_ = "url"
+    PropertySymbol 'Altitude_ = "altitude"
+    PropertySymbol 'Content_ = "content"
+    PropertySymbol 'ContentMap_ = "contentMap"
+    PropertySymbol 'Name_ = "name"
+    PropertySymbol 'NameMap_ = "nameMap"
+    PropertySymbol 'Duration_ = "duration"
+    PropertySymbol 'EndTime_ = "endTime"
+    PropertySymbol 'Height_ = "height"
+    PropertySymbol 'Href_ = "href"
+    PropertySymbol 'Hreflang_ = "hreflang"
+    PropertySymbol 'Latitude_ = "latitude"
+    PropertySymbol 'Longitude_ = "longitude"
+    PropertySymbol 'MediaType_ = "mediaType"
+    PropertySymbol 'Published_ = "published"
+    PropertySymbol 'Radius_ = "radius"
+    PropertySymbol 'Rating_ = "rating"
+    PropertySymbol 'Rel_ = "rel"
+    PropertySymbol 'StartIndex_ = "startIndex"
+    PropertySymbol 'StartTime_ = "startTime"
+    PropertySymbol 'Summary_ = "summary"
+    PropertySymbol 'SummaryMap_ = "summaryMap"
+    PropertySymbol 'TotalItems_ = "totalItems"
+    PropertySymbol 'Units_ = "units"
+    PropertySymbol 'Updated_ = "updated"
+    PropertySymbol 'Width_ = "width"
+    PropertySymbol 'Describes_ = "describes"
+    PropertySymbol 'FormerType_ = "formerType"
+    PropertySymbol 'Deleted_ = "deleted"
+
+    -- ActivityPub
+
+    PropertySymbol 'Endpoints_ = "endpoints"
+    PropertySymbol 'Following_ = "following"
+    PropertySymbol 'Followers_ = "followers"
+    PropertySymbol 'Inbox_ = "inbox"
+    PropertySymbol 'Liked_ = "liked"
+    PropertySymbol 'Shares_ = "shares"
+    PropertySymbol 'Likes_ = "likes"
+    PropertySymbol 'OauthAuthorizationEndpoint_ = "oauthAuthorizationEndpoint"
+    PropertySymbol 'OauthTokenEndpoint_ = "oauthTokenEndpoint"
+    PropertySymbol 'Outbox_ = "outbox"
+    PropertySymbol 'PreferredUsername_ = "preferredUsername"
+    PropertySymbol 'ProvideClientKey_ = "provideClientKey"
+    PropertySymbol 'ProxyUrl_ = "proxyUrl"
+    PropertySymbol 'SharedInbox_ = "sharedInbox"
+    PropertySymbol 'SignClientKey_ = "signClientKey"
+    PropertySymbol 'Source_ = "source"
+    PropertySymbol 'Streams_ = "streams"
+    PropertySymbol 'UploadMedia_ = "uploadMedia"
+
+req :: forall (p::Property) (a::Type) .
+       ( FromJSON a
+       , KnownSymbol (PropertySymbol p)
+       )
+    => Object
+    -> Parser a
+req obj = obj .: prop
+    where
+    prop = T.pack $ symbolVal @(PropertySymbol p) Proxy
+
+opt :: forall (p::Property) (a::Type) .
+       ( FromJSON a
+       , KnownSymbol (PropertySymbol p)
+       )
+    => Object
+    -> Parser (Maybe a)
+opt obj = obj .:? prop
+    where
+    prop = T.pack $ symbolVal @(PropertySymbol p) Proxy
+
+--instance ToJSONKey Property where
+--    toJSONKey = toJSONKeyText 

vervis.cabal

@@ -129,6 +129,7 @@ library
                        Text.Jasmine.Local
                        Web.ActivityAccess
                        Web.ActivityPub
+                       Web.ActivityPub.Internal
                        Web.Actor
                        Web.Actor.Deliver
                        Web.Actor.Persist