Eventually-decentralized project hosting and management platform

[[ 🗃 ^WvWbo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/WvWbo

SSH: darcs clone USERNAME@vervis.peers.community:WvWbo

Tags

TODO

src / Vervis / Persist /

Collab.hs

{- This file is part of Vervis.
 -
 - Written in 2022 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.Persist.Collab
    ( getCollabTopic
    , getGrantRecip
    , getTopicGrants
    , getTopicInvites
    , getTopicJoins
    )
where

import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Time.Clock
import Database.Persist.Sql

import qualified Database.Esqueleto as E

import Database.Persist.Local

import Vervis.Access
import Vervis.Data.Collab
import Vervis.Model

getCollabTopic
    :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
getCollabTopic collabID = do
    maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
    maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
    maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
    return $
        case (maybeRepo, maybeDeck, maybeLoom) of
            (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
            (Just r, Nothing, Nothing) ->
                GrantResourceRepo $ collabTopicRepoRepo r
            (Nothing, Just d, Nothing) ->
                GrantResourceDeck $ collabTopicDeckDeck d
            (Nothing, Nothing, Just l) ->
                GrantResourceLoom $ collabTopicLoomLoom l
            _ -> error "Found Collab with multiple topics"

getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e

getTopicGrants
    :: ( MonadIO m
       , PersistRecordBackend topic SqlBackend
       , PersistRecordBackend resource SqlBackend
       )
    => EntityField topic CollabId
    -> EntityField topic (Key resource)
    -> Key resource
    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)]
getTopicGrants topicCollabField topicActorField resourceID =
    fmap (map adapt) $
    E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab
        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab
        E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
        E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
        E.where_ $ topic E.^. topicActorField E.==. E.val resourceID
        E.orderBy [E.asc $ enable E.^. CollabEnableId]
        return
            ( recipL E.?. CollabRecipLocalPerson
            , recipR E.?. CollabRecipRemoteActor
            , grant E.^. OutboxItemPublished
            )
    where
    adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value time) =
        ( case (maybePersonID, maybeRemoteActorID) of
            (Nothing, Nothing) -> error "No recip"
            (Just personID, Nothing) -> Left personID
            (Nothing, Just remoteActorID) -> Right remoteActorID
            (Just _, Just _) -> error "Multi recip"
        , time
        )

getTopicInvites
    :: ( MonadIO m
       , PersistRecordBackend topic SqlBackend
       , PersistRecordBackend resource SqlBackend
       )
    => EntityField topic CollabId
    -> EntityField topic (Key resource)
    -> Key resource
    -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime)]
getTopicInvites topicCollabField topicActorField resourceID =
    fmap (map adapt) $
    E.select $ E.from $
    \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
      `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR
      `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor)
      `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity)
      ) -> do
        E.on $ inviterR E.?. CollabInviterRemoteInvite E.==. activity E.?. RemoteActivityId
        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterR E.?. CollabInviterRemoteCollab
        E.on $ item E.?. OutboxItemOutbox E.==. actor E.?. ActorOutbox
        E.on $ inviterL E.?. CollabInviterLocalInvite E.==. item E.?. OutboxItemId
        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterL E.?. CollabInviterLocalCollab
        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab
        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab
        E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab
        E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
        E.where_ $
            topic E.^. topicActorField E.==. E.val resourceID E.&&.
            E.isNothing (enable E.?. CollabEnableId)
        E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId]
        return
            ( actor E.?. ActorId
            , item E.?. OutboxItemPublished
            , inviterR E.?. CollabInviterRemoteActor
            , activity E.?. RemoteActivityReceived
            , recipL E.?. CollabRecipLocalPerson
            , recipR E.?. CollabRecipRemoteActor
            )
    where
    adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR) =
        let l = case (inviterL, timeL) of
                    (Nothing, Nothing) -> Nothing
                    (Just i, Just t) -> Just (i, t)
                    _ -> error "Impossible"
            r = case (inviterR, timeR) of
                    (Nothing, Nothing) -> Nothing
                    (Just i, Just t) -> Just (i, t)
                    _ -> error "Impossible"
            (inviter, time) =
                case (l, r) of
                    (Nothing, Nothing) -> error "No inviter"
                    (Just (actorID, time), Nothing) ->
                        (Left actorID, time)
                    (Nothing, Just (remoteActorID, time)) ->
                        (Right remoteActorID, time)
                    (Just _, Just _) -> error "Multi inviter"
        in  ( inviter
            , case (recipL, recipR) of
                (Nothing, Nothing) -> error "No recip"
                (Just personID, Nothing) -> Left personID
                (Nothing, Just remoteActorID) -> Right remoteActorID
                (Just _, Just _) -> error "Multi recip"
            , time
            )

getTopicJoins
    :: ( MonadIO m
       , PersistRecordBackend topic SqlBackend
       , PersistRecordBackend resource SqlBackend
       )
    => EntityField topic CollabId
    -> EntityField topic (Key resource)
    -> Key resource
    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)]
getTopicJoins topicCollabField topicActorField resourceID =
    fmap (map adapt) $
    E.select $ E.from $
    \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
      `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item)
      `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity)
      ) -> do
        E.on $ joinR E.?. CollabRecipRemoteJoinJoin E.==. activity E.?. RemoteActivityId
        E.on $ joinR E.?. CollabRecipRemoteJoinCollab E.==. recipR E.?. CollabRecipRemoteId
        E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinR E.?. CollabRecipRemoteJoinFulfills
        E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId
        E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId
        E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills
        E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab
        E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
        E.where_ $
            topic E.^. topicActorField E.==. E.val resourceID E.&&.
            E.isNothing (enable E.?. CollabEnableId)
        E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId]
        return
            ( recipL E.?. CollabRecipLocalPerson
            , item E.?. OutboxItemPublished
            , recipR E.?. CollabRecipRemoteActor
            , activity E.?. RemoteActivityReceived
            )
    where
    adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR) =
        let l = case (recipL, timeL) of
                    (Nothing, Nothing) -> Nothing
                    (Just r, Just t) -> Just (r, t)
                    _ -> error "Impossible"
            r = case (recipR, timeR) of
                    (Nothing, Nothing) -> Nothing
                    (Just r, Just t) -> Just (r, t)
                    _ -> error "Impossible"
        in  case (l, r) of
                (Nothing, Nothing) -> error "No recip"
                (Just (personID, time), Nothing) -> (Left personID, time)
                (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time)
                (Just _, Just _) -> error "Multi recip"
[See repo JSON]