Implement actor-model system and start moving Person actor to it

This patch makes Vervis temporarily unusable, because all actors' inbox POST
handlers use the new system, but the actual federation handler code hasn't been
ported. The next patches will port all the S2S activities supported so far, as
well as C2S.

src/Web/ActivityPub.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -79,6 +80,7 @@ module Web.ActivityPub
     , Undo (..)
     , Audience (..)
     , SpecificActivity (..)
+    , activityType
     , Action (..)
     , makeActivity
     , Activity (..)
@@ -174,6 +176,119 @@ import Web.Text
 
 import Data.Aeson.Local
 
+{-
+data Link = Link
+    { linkHref      :: URI
+    , linkRel       ::
+    , linkMediaType ::
+    , linkName      ::
+    , linkHreflang  ::
+    , linkHeight    ::
+    , linkWidth     ::
+    , linkPreview   ::
+    , linkRest      :: Object
+    }
+
+data X = X
+    { xId :: LocalURI
+    , x
+    }
+
+data Object' u = Object'
+    { objectId   :: ObjURI
+    , objectType ::
+
+    , objectSubject      ::
+    , objectRelationship ::
+    , objectActor        ::
+    , objectAttributedTo ::
+    , objectAttachment   ::
+    , objectBcc          ::
+    , objectBto          ::
+    , objectCc           ::
+    , objectContext      ::
+    , objectCurrent      ::
+    , objectFirst        ::
+    , objectGenerator    ::
+    , objectIcon         ::
+    , objectImage        ::
+    , objectInReplyTo    ::
+    , objectItems        ::
+    , objectInstrument   ::
+    , objectOrderedItems ::
+    , objectLast         ::
+    , objectLocation     ::
+    , objectNext         ::
+    , objectObject       ::
+    , objectOneOf        ::
+    , objectAnyOf        ::
+    , objectClosed       ::
+    , objectOrigin       ::
+    , objectAccuracy     ::
+    , objectPrev         ::
+    , objectPreview      ::
+    , objectProvider     ::
+    , objectReplies      ::
+    , objectResult       ::
+    , objectAudience     ::
+    , objectPartOf       ::
+    , objectTag          ::
+    , objectTags         ::
+    , objectTarget       ::
+    , objectTo           ::
+    , objectUrl          ::
+    , objectAltitude     ::
+    , objectContent      ::
+    , objectContentMap   ::
+    , objectName         ::
+    , objectNameMap      ::
+    , objectDuration     ::
+    , objectEndTime      ::
+    , objectHeight       ::
+    , objectHref         ::
+    , objectHreflang     ::
+    , objectLatitude     ::
+    , objectLongitude    ::
+    , objectMediaType    ::
+    , objectPublished    ::
+    , objectRadius       ::
+    , objectRating       ::
+    , objectRel          ::
+    , objectStartIndex   ::
+    , objectStartTime    ::
+    , objectSummary      ::
+    , objectSummaryMap   ::
+    , objectTotalItems   ::
+    , objectUnits        ::
+    , objectUpdated      ::
+    , objectWidth        ::
+    , objectDescribes    ::
+    , objectFormerType   ::
+    , objectDeleted      ::
+
+    , objectEndpoints                  ::
+    , objectFollowing                  ::
+    , objectFollowers                  ::
+    , objectInbox                      ::
+    , objectLiked                      ::
+    , objectShares                     ::
+    , objectLikes                      ::
+    , objectOauthAuthorizationEndpoint ::
+    , objectOauthTokenEndpoint         ::
+    , objectOutbox                     ::
+    , objectPreferredUsername          ::
+    , objectProvideClientKey           ::
+    , objectProxyUrl                   ::
+    , objectSharedInbox                ::
+    , objectSignClientKey              ::
+    , objectSource                     ::
+    , objectStreams                    ::
+    , objectUploadMedia                ::
+
+    , objectRest :: Object
+    }
+-}
+
 proxy :: a u -> Proxy a
 proxy _ = Proxy
 
@@ -1712,6 +1827,21 @@ data SpecificActivity u
     | ResolveActivity (Resolve u)
     | UndoActivity    (Undo u)
 
+activityType :: SpecificActivity u -> Text
+activityType (AcceptActivity _)  = "Accept"
+activityType (AddActivity _)     = "Add"
+activityType (ApplyActivity _)   = "Apply"
+activityType (CreateActivity _)  = "Create"
+activityType (FollowActivity _)  = "Follow"
+activityType (GrantActivity _)   = "Grant"
+activityType (InviteActivity _)  = "Invite"
+activityType (JoinActivity _)    = "Join"
+activityType (OfferActivity _)   = "Offer"
+activityType (PushActivity _)    = "Push"
+activityType (RejectActivity _)  = "Reject"
+activityType (ResolveActivity _) = "Resolve"
+activityType (UndoActivity _)    = "Undo"
+
 data Action u = Action
     { actionCapability :: Maybe (ObjURI u)
     , actionSummary    :: Maybe HTML
@@ -1782,20 +1912,6 @@ instance ActivityPub Activity where
         <> "fulfills"   .=% fulfills
         <> encodeSpecific authority actor specific
         where
-        activityType :: SpecificActivity u -> Text
-        activityType (AcceptActivity _)  = "Accept"
-        activityType (AddActivity _)     = "Add"
-        activityType (ApplyActivity _)   = "Apply"
-        activityType (CreateActivity _)  = "Create"
-        activityType (FollowActivity _)  = "Follow"
-        activityType (GrantActivity _)   = "Grant"
-        activityType (InviteActivity _)  = "Invite"
-        activityType (JoinActivity _)    = "Join"
-        activityType (OfferActivity _)   = "Offer"
-        activityType (PushActivity _)    = "Push"
-        activityType (RejectActivity _)  = "Reject"
-        activityType (ResolveActivity _) = "Resolve"
-        activityType (UndoActivity _)    = "Undo"
         encodeSpecific h _ (AcceptActivity a)  = encodeAccept h a
         encodeSpecific h _ (AddActivity a)     = encodeAdd h a
         encodeSpecific _ _ (ApplyActivity a)   = encodeApply a

src/Web/Actor.hs

@@ -0,0 +1,51 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2022, 2023 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/>.
+ -}
+
+-- | Reusable library for building decentralized actor-model-based web apps,
+-- with 'Control.Concurrent.Actor' for the local actor system, and ActivityPub
+-- as the network protocol.
+--
+-- At the time of writing (April 2023), this module is collecting the pieces
+-- that aren't tied to a specific web framework. Yesod-specific parts are in
+-- separate modules.
+--
+-- Ideally, the whole application structure would be specified using
+-- framework-independent tools, and framework integration (right now just
+-- Yesod, might also be Servant in the future) would be an automatic or
+-- auto-generated nearly-seamless part. I hope to get there, gradually, in
+-- steps of refactoring.
+module Web.Actor
+    ( StageWeb (..)
+    , ActForE
+    , hostIsLocal
+    )
+where
+
+import Control.Monad.Trans.Except
+import Data.Text (Text)
+
+import Control.Concurrent.Actor
+import Network.FedURI
+
+class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
+    type StageURIMode s
+    stageInstanceHost :: s -> Authority (StageURIMode s)
+
+type ActForE s = ExceptT Text (ActFor s)
+
+hostIsLocal
+    :: (MonadActor m, ActorEnv m ~ s, StageWeb s)
+    => Authority (StageURIMode s) -> m Bool
+hostIsLocal h = asksEnv $ (== h) . stageInstanceHost

src/Web/Actor/Persist.hs

@@ -0,0 +1,137 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 2023 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 Web.Actor.Persist
+    ( StageHashids (..)
+    , KeyHashid ()
+    , keyHashidText
+
+    , encodeKeyHashidPure
+    --, getEncodeKeyHashid
+    --, encodeKeyHashid
+
+    , decodeKeyHashidPure
+    --, decodeKeyHashid
+    --, decodeKeyHashidF
+    --, decodeKeyHashidM
+    , decodeKeyHashidE
+    )
+where
+
+import Prelude hiding (fail)
+
+import Control.Monad.Fail
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Text (Text)
+import Data.Text.Encoding
+import Database.Persist.Class
+import Database.Persist.Sql
+import Web.Hashids
+import Web.PathPieces
+
+import Control.Concurrent.Actor
+import Web.Actor
+--import Yesod.MonadActor
+
+import Web.Hashids.Local
+
+class StageWeb s => StageHashids s where
+    stageHashidsContext :: s -> HashidsContext
+
+newtype KeyHashid record = KeyHashid
+    { keyHashidText :: Text
+    }
+    deriving (Eq, Ord, Read, Show)
+
+instance PersistEntity record => PathPiece (KeyHashid record) where
+    fromPathPiece t = KeyHashid <$> fromPathPiece t
+    toPathPiece (KeyHashid t) = toPathPiece t
+
+encodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext -> Key record -> KeyHashid record
+encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
+
+getEncodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => m (Key record -> KeyHashid record)
+getEncodeKeyHashid = do
+    ctx <- asksEnv stageHashidsContext
+    return $ encodeKeyHashidPure ctx
+
+encodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => Key record
+    -> m (KeyHashid record)
+encodeKeyHashid k = do
+    enc <- getEncodeKeyHashid
+    return $ enc k
+
+decodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext
+    -> KeyHashid record
+    -> Maybe (Key record)
+decodeKeyHashidPure ctx (KeyHashid t) =
+    fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
+
+decodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> m (Maybe (Key record))
+decodeKeyHashid khid = do
+    ctx <- asksEnv stageHashidsContext
+    return $ decodeKeyHashidPure ctx khid
+
+decodeKeyHashidF
+    :: ( MonadFail m
+       , MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> String
+    -> m (Key record)
+decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid
+
+decodeKeyHashidM
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> MaybeT m (Key record)
+decodeKeyHashidM = MaybeT . decodeKeyHashid
+
+decodeKeyHashidE
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> e
+    -> ExceptT e m (Key record)
+decodeKeyHashidE khid e =
+    ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid