Unfinished updated outbox handler
This commit is contained in:
fr33domlover
parent
7dda068ba3
commit
9a306e762c
16 changed files with 871 additions and 18 deletions
|
|
@ -48,6 +48,12 @@ OutboxItem
|
|||
activity PersistActivity
|
||||
published UTCTime
|
||||
|
||||
InboxItemLocal
|
||||
person PersonId
|
||||
activity OutboxItemId
|
||||
|
||||
UniqueInboxItemLocal person activity
|
||||
|
||||
VerifKey
|
||||
ident LocalURI
|
||||
instance InstanceId
|
||||
|
|
|
|||
|
|
@ -138,5 +138,7 @@
|
|||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepR POST DELETE
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/team TicketTeamR GET
|
||||
|
||||
/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET
|
||||
|
|
|
|||
17
migrations/2019_04_11.model
Normal file
17
migrations/2019_04_11.model
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
InboxItemLocal
|
||||
person PersonId
|
||||
activity OutboxItemId
|
||||
|
||||
UniqueInboxItemLocal person activity
|
||||
|
||||
Follow
|
||||
person PersonId
|
||||
target FollowerSetId
|
||||
|
||||
UniqueFollow person target
|
||||
|
||||
RemoteFollow
|
||||
actor RemoteSharerId
|
||||
target FollowerSetId
|
||||
|
||||
UniqueRemoteFollow actor target
|
||||
97
src/Control/Concurrent/ResultShare.hs
Normal file
97
src/Control/Concurrent/ResultShare.hs
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
{- 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/>.
|
||||
-}
|
||||
|
||||
-- | This module provides a structure that allows multiple threads that need to
|
||||
-- run the same action, to run it only once, and let all the threads get the
|
||||
-- result. For example, suppose in multiple places in your concurrent program,
|
||||
-- it needs to download some file over the network. Using 'ResultShare', the
|
||||
-- download is started when it's first requested, and if during the download
|
||||
-- other threads request it too, they instead wait for that existing download
|
||||
-- to complete and they all get that same file once it's downloaded.
|
||||
--
|
||||
-- Note that the result is deleted from the structure once the action
|
||||
-- completes! So if you'd like that downloaded file to be reused after the
|
||||
-- download completes, use some separate structure for that.
|
||||
--
|
||||
-- Limitations:
|
||||
--
|
||||
-- * The settings constructor is exposed, and there's no defaults, not
|
||||
-- allowing to add settings in a backward compatible way
|
||||
-- * It could be nice to provide defaults for plain IO and for UnliftIO
|
||||
-- * The action is constant, could make it more flexible
|
||||
module Control.Concurrent.ResultShare
|
||||
( ResultShareSettings (..)
|
||||
, ResultShare ()
|
||||
, newResultShare
|
||||
, runShared
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.STM
|
||||
import Data.Hashable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
||||
import qualified Data.HashMap.Strict as M
|
||||
|
||||
data ResultShareSettings m k v a = ResultShareSettings
|
||||
{ resultShareFork :: m () -> m ()
|
||||
, resultShareAction :: k -> a -> m v
|
||||
}
|
||||
|
||||
data ResultShare m k v a = ResultShare
|
||||
{ _rsMap :: TVar (HashMap k (MVar v))
|
||||
, _rsFork :: m () -> m ()
|
||||
, _rsAction :: k -> a -> m v
|
||||
}
|
||||
|
||||
newResultShare
|
||||
:: MonadIO m => ResultShareSettings m k v a -> m (ResultShare m k v a)
|
||||
newResultShare (ResultShareSettings fork action) = do
|
||||
tvar <- liftIO $ newTVarIO M.empty
|
||||
return $ ResultShare tvar fork action
|
||||
|
||||
-- TODO this is copied from stm-2.5, remove when we upgrade LTS
|
||||
stateTVar :: TVar s -> (s -> (a, s)) -> STM a
|
||||
stateTVar var f = do
|
||||
s <- readTVar var
|
||||
let (a, s') = f s -- since we destructure this, we are strict in f
|
||||
writeTVar var s'
|
||||
return a
|
||||
|
||||
runShared
|
||||
:: (MonadIO m, Eq k, Hashable k) => ResultShare m k v a -> k -> a -> m v
|
||||
runShared (ResultShare tvar fork action) key param = do
|
||||
(mvar, new) <- liftIO $ do
|
||||
existing <- M.lookup key <$> readTVarIO tvar
|
||||
case existing of
|
||||
Just v -> return (v, False)
|
||||
Nothing -> do
|
||||
v <- newEmptyMVar
|
||||
atomically $ stateTVar tvar $ \ m ->
|
||||
case M.lookup key m of
|
||||
Just v' -> ((v', False), m)
|
||||
Nothing -> ((v , True) , M.insert key v m)
|
||||
when new $ fork $ do
|
||||
result <- action key param
|
||||
liftIO $ do
|
||||
atomically $ modifyTVar' tvar $ M.delete key
|
||||
putMVar mvar result
|
||||
liftIO $ readMVar mvar
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -21,6 +21,7 @@ module Data.List.Local
|
|||
, groupMap
|
||||
, groupMapBy
|
||||
, groupMapBy1
|
||||
, lookupSorted
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -97,3 +98,11 @@ groupMapBy1 eq f g = go
|
|||
[] -> []
|
||||
z:l -> toList $ go $ z :| l
|
||||
in (f x, g x :| map g ys) :| rest
|
||||
|
||||
lookupSorted :: Ord a => a -> [(a, b)] -> Maybe b
|
||||
lookupSorted _ [] = Nothing
|
||||
lookupSorted x ((y, z) : l) =
|
||||
case compare x y of
|
||||
LT -> lookupSorted x l
|
||||
EQ -> Just z
|
||||
GT -> Nothing
|
||||
|
|
|
|||
60
src/Data/List/NonEmpty/Local.hs
Normal file
60
src/Data/List/NonEmpty/Local.hs
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
{- 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 Data.List.NonEmpty.Local
|
||||
( groupWithExtract
|
||||
, groupWithExtractBy
|
||||
, groupWithExtractBy1
|
||||
, groupAllExtract
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Function
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
||||
extract :: (a -> b) -> (a -> c) -> NonEmpty a -> (b, NonEmpty c)
|
||||
extract f g (head :| tail) = (f head, g head :| map g tail)
|
||||
|
||||
groupWithExtract
|
||||
:: (Foldable f, Eq b)
|
||||
=> (a -> b)
|
||||
-> (a -> c)
|
||||
-> f a
|
||||
-> [(b, NonEmpty c)]
|
||||
groupWithExtract f g = map (extract f g) . NE.groupWith f
|
||||
|
||||
groupWithExtractBy
|
||||
:: Foldable f
|
||||
=> (b -> b -> Bool)
|
||||
-> (a -> b)
|
||||
-> (a -> c)
|
||||
-> f a
|
||||
-> [(b, NonEmpty c)]
|
||||
groupWithExtractBy eq f g = map (extract f g) . NE.groupBy (eq `on` f)
|
||||
|
||||
groupWithExtractBy1
|
||||
:: (b -> b -> Bool)
|
||||
-> (a -> b)
|
||||
-> (a -> c)
|
||||
-> NonEmpty a
|
||||
-> NonEmpty (b, NonEmpty c)
|
||||
groupWithExtractBy1 eq f g = NE.map (extract f g) . NE.groupBy1 (eq `on` f)
|
||||
|
||||
groupAllExtract :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
|
||||
groupAllExtract f g = map (extract f g) . NE.groupAllWith f
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -14,12 +14,19 @@
|
|||
-}
|
||||
|
||||
module Data.Maybe.Local
|
||||
( partitionMaybePairs
|
||||
( partitionMaybes
|
||||
, partitionMaybePairs
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b])
|
||||
partitionMaybes = foldr f ([], [])
|
||||
where
|
||||
f (Nothing, y) (ps, ys) = (ps , y : ys)
|
||||
f (Just x , y) (ps, ys) = ((x, y) : ps, ys)
|
||||
|
||||
partitionMaybePairs :: [(Maybe a, Maybe b)] -> ([a], [b], [(a, b)])
|
||||
partitionMaybePairs = foldr f ([], [], [])
|
||||
where
|
||||
|
|
|
|||
|
|
@ -18,16 +18,22 @@ module Database.Persist.Local
|
|||
, getKeyBy
|
||||
, getValBy
|
||||
, insertUnique_
|
||||
, insertBy'
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Database.Persist
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
|
||||
idAndNew (Left (Entity iid _)) = (iid, False)
|
||||
idAndNew (Right iid) = (iid, True)
|
||||
|
|
@ -58,3 +64,21 @@ insertUnique_
|
|||
=> record
|
||||
-> ReaderT backend m ()
|
||||
insertUnique_ = void . insertUnique
|
||||
|
||||
insertBy'
|
||||
:: ( MonadIO m
|
||||
, PersistUniqueWrite backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> record -> ReaderT backend m (Either (Entity record) (Key record))
|
||||
insertBy' val = do
|
||||
let tryGet = Left <$> MaybeT (getByValue val)
|
||||
tryWrite = Right <$> MaybeT (insertUnique val)
|
||||
mresult <- runMaybeT $ tryGet <|> tryWrite <|> tryGet
|
||||
case mresult of
|
||||
Just result -> return result
|
||||
Nothing ->
|
||||
liftIO $ throwIO $ PersistError $
|
||||
"insertBy': Couldn't insert but also couldn't get the value, \
|
||||
\perhaps it was concurrently deleted or updated: " <>
|
||||
T.pack (show $ map toPersistValue $ toPersistFields val)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Network.FedURI
|
||||
( FedURI (..)
|
||||
, parseFedURI
|
||||
|
|
@ -36,10 +38,12 @@ import Prelude
|
|||
import Control.Monad ((<=<))
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor (bimap, first)
|
||||
import Data.Hashable
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Class (PersistField (..))
|
||||
import Database.Persist.Sql (PersistFieldSql (..))
|
||||
import GHC.Generics (Generic)
|
||||
import Network.URI
|
||||
|
||||
import qualified Data.Text as T (pack, unpack, stripPrefix)
|
||||
|
|
@ -57,7 +61,9 @@ data FedURI = FedURI
|
|||
, furiPath :: Text
|
||||
, furiFragment :: Text
|
||||
}
|
||||
deriving Eq
|
||||
deriving (Eq, Generic)
|
||||
|
||||
instance Hashable FedURI
|
||||
|
||||
instance FromJSON FedURI where
|
||||
parseJSON = withText "FedURI" $ either fail return . parseFedURI
|
||||
|
|
|
|||
|
|
@ -22,28 +22,36 @@ where
|
|||
import Prelude
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Exception hiding (Handler, try)
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Aeson (Object)
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Function
|
||||
import Data.List (sort, deleteBy, nub, union, unionBy)
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Semigroup
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Data.Tuple
|
||||
import Database.Persist hiding (deleteBy)
|
||||
import Database.Persist.Sql hiding (deleteBy)
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.URI
|
||||
import UnliftIO.Exception (try)
|
||||
import Yesod.Core hiding (logError, logWarn, logInfo)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.Ordered as LO
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Network.HTTP.Signature
|
||||
|
|
@ -56,6 +64,8 @@ import Yesod.FedURI
|
|||
import Yesod.Hashids
|
||||
|
||||
import Data.Either.Local
|
||||
import Data.List.Local
|
||||
import Data.List.NonEmpty.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.ActorKey
|
||||
|
|
@ -286,6 +296,7 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
|
|||
]
|
||||
return (uNote, luContext)
|
||||
|
||||
{-
|
||||
-- | Handle a Note submitted by a local user to their outbox. It can be either
|
||||
-- a comment on a local ticket, or a comment on some remote context. Return an
|
||||
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
|
||||
|
|
@ -297,6 +308,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
|
|||
uContext <- fromMaybeE muContext "Note without context"
|
||||
uRecip <- parseAudience aud "Note has not-just-single-to audience"
|
||||
recipContextParent <- parseRecipContextParent uRecip uContext muParent
|
||||
|
||||
(lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
|
||||
(pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
|
||||
case recipContextParent of
|
||||
|
|
@ -606,3 +618,556 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
|
|||
doc = activity luAct
|
||||
update obid [OutboxItemActivity =. PersistJSON doc]
|
||||
return (lmid, doc)
|
||||
-}
|
||||
|
||||
data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalProjectRecipient
|
||||
= LocalProject
|
||||
| LocalTicketRelated Int LocalTicketRecipient
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalSharerRecipient
|
||||
= LocalSharer
|
||||
| LocalProjectRelated PrjIdent LocalProjectRecipient
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalTicketRelatedSet
|
||||
= OnlyTicketParticipants
|
||||
| OnlyTicketTeam
|
||||
| BothTicketParticipantsAndTeam
|
||||
|
||||
data LocalProjectRelatedSet = LocalProjectRelatedSet
|
||||
{ localRecipProject :: Bool
|
||||
, localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
|
||||
}
|
||||
|
||||
data LocalSharerRelatedSet = LocalSharerRelatedSet
|
||||
{ localRecipSharer :: Bool
|
||||
, localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
|
||||
}
|
||||
|
||||
type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]
|
||||
|
||||
newtype FedError = FedError Text deriving Show
|
||||
|
||||
instance Exception FedError
|
||||
|
||||
-- | Handle a Note submitted by a local user to their outbox. It can be either
|
||||
-- a comment on a local ticket, or a comment on some remote context. Return an
|
||||
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
|
||||
handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
|
||||
handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
|
||||
verifyHostLocal host "Attributed to non-local actor"
|
||||
verifyNothing mluNote "Note specifies an id"
|
||||
verifyNothing mpublished "Note specifies published"
|
||||
uContext <- fromMaybeE muContext "Note without context"
|
||||
recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
|
||||
(mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
|
||||
result <- lift $ try $ runDB $ (either abort return =<<) . runExceptT $ do
|
||||
(pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
|
||||
(did, meparent, mcollections) <- case mticket of
|
||||
Just (shr, prj, num) -> do
|
||||
mt <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
|
||||
t <- MaybeT $ getValBy $ UniqueTicket jid num
|
||||
return (sid, t)
|
||||
(sid, t) <- fromMaybeE mt "Context: No such local ticket"
|
||||
let did = ticketDiscuss t
|
||||
mmidParent <- for mparent $ \ parent ->
|
||||
case parent of
|
||||
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
|
||||
Right (hParent, luParent) -> do
|
||||
mrm <- lift $ runMaybeT $ do
|
||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
||||
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
|
||||
rm <- fromMaybeE mrm "Remote parent unknown locally"
|
||||
let mid = remoteMessageRest rm
|
||||
m <- lift $ getJust mid
|
||||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
return mid
|
||||
return (did, Left <$> mmidParent, Just (sid, ticketFollowers t))
|
||||
Nothing -> do
|
||||
(rd, rdnew) <- do
|
||||
let (hContext, luContext) = f2l uContext
|
||||
miid <- lift $ getKeyBy $ UniqueInstance hContext
|
||||
mrd <-
|
||||
case miid of
|
||||
Just iid -> lift $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
|
||||
Nothing -> return Nothing
|
||||
case mrd of
|
||||
Just rd -> return (rd, False)
|
||||
Nothing -> lift $ withHostLock hContext $ do
|
||||
(iid, inew) <-
|
||||
case miid of
|
||||
Just i -> return (i, False)
|
||||
Nothing -> idAndNew <$> insertBy (Instance hContext)
|
||||
if inew
|
||||
then do
|
||||
did <- insert Discussion
|
||||
rd <- insertRecord $ RemoteDiscussion iid luContext did
|
||||
return (rd, True)
|
||||
else do
|
||||
mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
|
||||
case mrd of
|
||||
Just rd -> return (rd, False)
|
||||
Nothing -> do
|
||||
did <- insert Discussion
|
||||
rd <- insertRecord $ RemoteDiscussion iid luContext did
|
||||
return (rd, True)
|
||||
let did = remoteDiscussionDiscuss rd
|
||||
meparent <- for mparent $ \ parent ->
|
||||
case parent of
|
||||
Left (shrParent, lmidParent) -> do
|
||||
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
|
||||
Left <$> getLocalParentMessageId did shrParent lmidParent
|
||||
Right (hParent, luParent) -> do
|
||||
mrm <- lift $ runMaybeT $ do
|
||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
||||
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
|
||||
case mrm of
|
||||
Nothing -> return $ Right $ l2f hParent luParent
|
||||
Just rm -> Left <$> do
|
||||
let mid = remoteMessageRest rm
|
||||
m <- lift $ getJust mid
|
||||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
return mid
|
||||
return (did, meparent, Nothing)
|
||||
(lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
|
||||
moreRemotes <- deliverLocal obid localRecips mcollections
|
||||
return (lmid, doc, moreRemotes)
|
||||
(lmid, doc, moreRemotes) <- case result of
|
||||
Left (FedError t) -> throwE t
|
||||
Right r -> return r
|
||||
-- TODO deliver *async* to remote sharers: remoteRecips and moreRemotes
|
||||
--
|
||||
-- doc :: Doc Activity
|
||||
-- remoteRecips :: [FedURI]
|
||||
-- moreRemotes :: [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
|
||||
return lmid
|
||||
where
|
||||
verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
|
||||
verifyNothing Nothing _ = return ()
|
||||
verifyNothing (Just _) e = throwE e
|
||||
|
||||
concatRecipients :: Audience -> [FedURI]
|
||||
concatRecipients (Audience to bto cc bcc gen) = concat [to, bto, cc, bcc, gen]
|
||||
|
||||
nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
|
||||
nonEmptyE l e =
|
||||
case nonEmpty l of
|
||||
Nothing -> throwE e
|
||||
Just ne -> return ne
|
||||
|
||||
parseRecipsContextParent
|
||||
:: NonEmpty FedURI
|
||||
-> FedURI
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler
|
||||
( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
|
||||
, [ShrIdent]
|
||||
, Maybe (ShrIdent, PrjIdent, Int)
|
||||
, [FedURI]
|
||||
)
|
||||
parseRecipsContextParent recips uContext muParent = do
|
||||
(locals, remotes) <- lift $ splitRecipients recips
|
||||
let (localsParsed, localsRest) = parseLocalRecipients locals
|
||||
unless (null localsRest) $
|
||||
throwE "Note has invalid local recipients"
|
||||
let localsSet = groupLocalRecipients localsParsed
|
||||
(hContext, luContext) = f2l uContext
|
||||
parent <- parseParent uContext muParent
|
||||
local <- hostIsLocal hContext
|
||||
if local
|
||||
then do
|
||||
ticket <- parseContextTicket luContext
|
||||
shrs <- verifyTicketRecipients ticket localsSet
|
||||
return (parent, shrs, Just ticket, remotes)
|
||||
else do
|
||||
shrs <- verifyOnlySharers localsSet
|
||||
return (parent, shrs, Nothing, remotes)
|
||||
where
|
||||
-- First step: Split into remote and local:
|
||||
splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI])
|
||||
splitRecipients recips = do
|
||||
home <- getsYesod $ appInstanceHost . appSettings
|
||||
let (local, remote) = NE.partition ((== home) . furiHost) recips
|
||||
return (map (snd . f2l) local, remote)
|
||||
|
||||
-- Parse the local recipients
|
||||
parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)])
|
||||
parseLocalRecipients = swap . partitionEithers . map decide
|
||||
where
|
||||
parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
|
||||
parseLocalRecipient (ProjectR shr prj) =
|
||||
Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
|
||||
parseLocalRecipient (TicketParticipantsR shr prj num) =
|
||||
Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
|
||||
parseLocalRecipient (TicketTeamR shr prj num) =
|
||||
Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam
|
||||
parseLocalRecipient _ = Nothing
|
||||
decide lu =
|
||||
case decodeRouteLocal lu of
|
||||
Nothing -> Left $ Left lu
|
||||
Just route ->
|
||||
case parseLocalRecipient route of
|
||||
Nothing -> Left $ Right route
|
||||
Just lr -> Right lr
|
||||
|
||||
-- Group local recipients
|
||||
groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet
|
||||
groupLocalRecipients
|
||||
= map
|
||||
( second
|
||||
$ uncurry LocalSharerRelatedSet
|
||||
. bimap
|
||||
(not . null)
|
||||
( map
|
||||
( second
|
||||
$ uncurry LocalProjectRelatedSet
|
||||
. bimap
|
||||
(not . null)
|
||||
( map (second ltrs2ltrs)
|
||||
. groupWithExtract fst snd
|
||||
)
|
||||
. partitionEithers
|
||||
. NE.toList
|
||||
)
|
||||
. groupWithExtract fst (lpr2e . snd)
|
||||
)
|
||||
. partitionEithers
|
||||
. NE.toList
|
||||
)
|
||||
. groupWithExtract
|
||||
(\ (LocalSharerRelated shr _) -> shr)
|
||||
(\ (LocalSharerRelated _ lsr) -> lsr2e lsr)
|
||||
. sort
|
||||
where
|
||||
lsr2e LocalSharer = Left ()
|
||||
lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
|
||||
lpr2e LocalProject = Left ()
|
||||
lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
|
||||
ltrs2ltrs (LocalTicketParticipants :| l) =
|
||||
if LocalTicketTeam `elem` l
|
||||
then BothTicketParticipantsAndTeam
|
||||
else OnlyTicketParticipants
|
||||
ltrs2ltrs (LocalTicketTeam :| l) =
|
||||
if LocalTicketParticipants `elem` l
|
||||
then BothTicketParticipantsAndTeam
|
||||
else OnlyTicketTeam
|
||||
|
||||
parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
|
||||
parseParent _ Nothing = return Nothing
|
||||
parseParent uContext (Just uParent) =
|
||||
if uParent == uContext
|
||||
then return Nothing
|
||||
else Just <$> do
|
||||
let (hParent, luParent) = f2l uParent
|
||||
parentLocal <- hostIsLocal hParent
|
||||
if parentLocal
|
||||
then Left <$> parseComment luParent
|
||||
else return $ Right (hParent, luParent)
|
||||
|
||||
parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
|
||||
parseContextTicket luContext = do
|
||||
route <- case decodeRouteLocal luContext of
|
||||
Nothing -> throwE "Local context isn't a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
TicketR shr prj num -> return (shr, prj, num)
|
||||
_ -> throwE "Local context isn't a ticket route"
|
||||
|
||||
atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
|
||||
atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing
|
||||
atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e
|
||||
|
||||
verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
|
||||
verifyTicketRecipients (shr, prj, num) recips = do
|
||||
lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
|
||||
(prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
|
||||
unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
|
||||
unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
|
||||
(num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
|
||||
unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
|
||||
case ltrSet of
|
||||
OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
|
||||
OnlyTicketTeam -> throwE "Note ticket team not addressed"
|
||||
BothTicketParticipantsAndTeam -> return ()
|
||||
let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
|
||||
orig = if localRecipSharer lsrSet then Just shr else Nothing
|
||||
catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
|
||||
where
|
||||
verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
|
||||
verifySingleton [] t = throwE $ t <> ": expected 1, got 0"
|
||||
verifySingleton [x] _ = return x
|
||||
verifySingleton l t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
|
||||
|
||||
verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
|
||||
verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
|
||||
|
||||
abort :: Text -> AppDB a
|
||||
abort = liftIO . throwIO . FedError
|
||||
|
||||
verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
|
||||
verifyIsLoggedInUser lu t = do
|
||||
Entity pid p <- requireVerifiedAuth
|
||||
s <- lift $ getJust $ personIdent p
|
||||
route2local <- getEncodeRouteLocal
|
||||
let shr = sharerIdent s
|
||||
if route2local (SharerR shr) == lu
|
||||
then return (pid, shr)
|
||||
else throwE t
|
||||
|
||||
insertMessage
|
||||
:: LocalURI
|
||||
-> ShrIdent
|
||||
-> PersonId
|
||||
-> FedURI
|
||||
-> DiscussionId
|
||||
-> Maybe FedURI
|
||||
-> Maybe (Either MessageId FedURI)
|
||||
-> Text
|
||||
-> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
|
||||
insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
|
||||
now <- liftIO getCurrentTime
|
||||
mid <- insert Message
|
||||
{ messageCreated = now
|
||||
, messageContent = content
|
||||
, messageParent =
|
||||
case meparent of
|
||||
Just (Left midParent) -> Just midParent
|
||||
_ -> Nothing
|
||||
, messageRoot = did
|
||||
}
|
||||
lmid <- insert LocalMessage
|
||||
{ localMessageAuthor = pid
|
||||
, localMessageRest = mid
|
||||
, localMessageUnlinkedParent =
|
||||
case meparent of
|
||||
Just (Right uParent) -> Just uParent
|
||||
_ -> Nothing
|
||||
}
|
||||
route2local <- getEncodeRouteLocal
|
||||
lmhid <- encodeKeyHashid lmid
|
||||
let activity luAct = Doc host Activity
|
||||
{ activityId = luAct
|
||||
, activityActor = luAttrib
|
||||
, activityAudience = aud
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = Note
|
||||
{ noteId = Just $ route2local $ MessageR shrUser lmhid
|
||||
, noteAttrib = luAttrib
|
||||
, noteAudience = aud
|
||||
, noteReplyTo = Just $ fromMaybe uContext muParent
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Just now
|
||||
, noteContent = content
|
||||
}
|
||||
}
|
||||
}
|
||||
obid <- insert OutboxItem
|
||||
{ outboxItemPerson = pid
|
||||
, outboxItemActivity = PersistJSON $ activity $ LocalURI "" ""
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obhid <- encodeKeyHashid obid
|
||||
let luAct = route2local $ OutboxItemR shrUser obhid
|
||||
doc = activity luAct
|
||||
update obid [OutboxItemActivity =. PersistJSON doc]
|
||||
return (lmid, obid, doc)
|
||||
|
||||
-- | Merge 2 lists ordered on fst, concatenating snd values when
|
||||
-- multiple identical fsts occur. The resulting list is ordered on fst,
|
||||
-- and each fst value appears only once.
|
||||
--
|
||||
-- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
|
||||
-- [('a',6), ('b',5), ('c',4)]
|
||||
mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
|
||||
mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys
|
||||
|
||||
-- Deliver to local recipients. For local users, find in DB and deliver.
|
||||
-- For local collections, expand them, deliver to local users, and return a
|
||||
-- list of remote actors found in them.
|
||||
deliverLocal
|
||||
:: OutboxItemId
|
||||
-> [ShrIdent]
|
||||
-> Maybe (SharerId, FollowerSetId)
|
||||
-> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
|
||||
deliverLocal obid recips mticket = do
|
||||
recipPids <- traverse getPersonId $ nub recips
|
||||
(morePids, remotes) <-
|
||||
lift $ case mticket of
|
||||
Nothing -> return ([], [])
|
||||
Just (sid, fsid) -> do
|
||||
(teamPids, teamRemotes) <- getTicketTeam sid
|
||||
(fsPids, fsRemotes) <- getFollowers fsid
|
||||
return
|
||||
( union teamPids fsPids
|
||||
-- TODO this is inefficient! The way this combines
|
||||
-- same-host sharer lists is:
|
||||
--
|
||||
-- (1) concatenate them
|
||||
-- (2) nubBy fst to remove duplicates
|
||||
--
|
||||
-- But we have knowledge that:
|
||||
--
|
||||
-- (1) in each of the 2 lists we're combining, each
|
||||
-- instance occurs only once
|
||||
-- (2) in each actor list, each actor occurs only
|
||||
-- once
|
||||
--
|
||||
-- So we can improve this code by:
|
||||
--
|
||||
-- (1) Not assume arbitrary number of consecutive
|
||||
-- repetition of the same instance, we may only
|
||||
-- have repetition if the same instance occurs
|
||||
-- in both lists
|
||||
-- (2) Don't <> the lists, instead apply unionBy or
|
||||
-- something better (unionBy assumes one list
|
||||
-- may have repetition, but removes repetition
|
||||
-- from the other; we know both lists have no
|
||||
-- repetition, can we use that to do this
|
||||
-- faster than unionBy?)
|
||||
--
|
||||
-- Also, if we ask the DB to sort by actor, then in
|
||||
-- the (2) point above, instead of unionBy we can use
|
||||
-- the knowledge the lists are sorted, and apply
|
||||
-- LO.unionBy instead. Or even better, because
|
||||
-- LO.unionBy doesn't assume no repetitions (possibly
|
||||
-- though it still does it the fastest way).
|
||||
--
|
||||
-- So, in mergeConcat, don't start with merging,
|
||||
-- because we lose the knowledge that each list's
|
||||
-- instances aren't repeated. Use a custom merge
|
||||
-- where we can unionBy or LO.unionBy whenever both
|
||||
-- lists have the same instance.
|
||||
, map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat teamRemotes fsRemotes
|
||||
)
|
||||
lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
|
||||
return remotes
|
||||
where
|
||||
getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
|
||||
getPersonOrGroupId sid = do
|
||||
mpid <- getKeyBy $ UniquePersonIdent sid
|
||||
mgid <- getKeyBy $ UniqueGroup sid
|
||||
requireEitherM mpid mgid
|
||||
"Found sharer that is neither person nor group"
|
||||
"Found sharer that is both person and group"
|
||||
getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
|
||||
getPersonId shr = do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
|
||||
id_ <- lift $ getPersonOrGroupId sid
|
||||
case id_ of
|
||||
Left pid -> return pid
|
||||
Right _gid -> throwE "Local Note addresses a local group"
|
||||
groupRemotes :: [(InstanceId, Text, RemoteSharerId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
|
||||
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs
|
||||
where
|
||||
toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu))
|
||||
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
|
||||
getTicketTeam sid = do
|
||||
id_ <- getPersonOrGroupId sid
|
||||
(,[]) <$> case id_ of
|
||||
Left pid -> return [pid]
|
||||
Right gid ->
|
||||
map (groupMemberPerson . entityVal) <$>
|
||||
selectList [GroupMemberGroup ==. gid] []
|
||||
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
|
||||
getFollowers fsid = do
|
||||
local <- selectList [FollowTarget ==. fsid] []
|
||||
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
|
||||
E.on $ rs E.^. RemoteSharerInstance E.==. i E.^. InstanceId
|
||||
E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteSharerId
|
||||
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
|
||||
E.orderBy [E.asc $ i E.^. InstanceId]
|
||||
return
|
||||
( i E.^. InstanceId
|
||||
, i E.^. InstanceHost
|
||||
, rs E.^. RemoteSharerId
|
||||
, rs E.^. RemoteSharerInbox
|
||||
)
|
||||
return
|
||||
( map (followPerson . entityVal) local
|
||||
, groupRemotes $
|
||||
map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox) ->
|
||||
(iid, h, rsid, luInbox)
|
||||
)
|
||||
remote
|
||||
)
|
||||
|
||||
-- Deliver to a local sharer, if they exist as a user account
|
||||
deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
|
||||
deliverToLocalSharer obid shr = do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
|
||||
mpid <- lift $ getKeyBy $ UniquePersonIdent sid
|
||||
mgid <- lift $ getKeyBy $ UniqueGroup sid
|
||||
id_ <-
|
||||
requireEitherM mpid mgid
|
||||
"Found sharer that is neither person nor group"
|
||||
"Found sharer that is both person and group"
|
||||
case id_ of
|
||||
Left pid -> lift $ insert_ $ InboxItemLocal pid obid
|
||||
Right _gid -> throwE "Local Note addresses a local group"
|
||||
|
||||
-- TODO NEXT: So far, we have 2 groups of remote actors to handle,
|
||||
-- 'allKnown' and 'stillUnknown'. We could be done with DB and proceed to
|
||||
-- launch HTTP requests, but we haven't considered something: Some actors
|
||||
-- are known to be unreachable:
|
||||
--
|
||||
-- (1) There are actors we've never reached, for whom there are pending
|
||||
-- deliveries
|
||||
-- (2) There are actors we already fetched, but for whom there are
|
||||
-- pending deliveries because lately their inboxes are unreachable
|
||||
--
|
||||
-- And this brings us to 2 potential things to do:
|
||||
--
|
||||
-- (1) Skip the request for some actors, and instead insert a delivery to
|
||||
-- the DB
|
||||
-- (2) Insert/update reachability records for actors we try to reach but
|
||||
-- fail
|
||||
-- (3) Insert/update reachability records for actors we suddenly succeed
|
||||
-- to reach
|
||||
--
|
||||
-- So, for each RemoteSharer, we're going to add a field 'errorSince'.
|
||||
-- Its type will be Maybe UTCTime, and the meaning is:
|
||||
--
|
||||
-- - Nothing: We haven't observed the inbox being down
|
||||
-- - Just t: The time t denotes a time we couldn't reach the inbox, and
|
||||
-- since that time all our following attempts failed too
|
||||
--
|
||||
-- In this context, inbox error means any result that isn't a 2xx status.
|
||||
deliverRemote :: Doc Activity -> [FedURI] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] -> Handler ()
|
||||
deliverRemote doc recips known = runDB $ do
|
||||
recips' <- for (groupByHost recips) $ \ (h, lus) -> do
|
||||
let lus' = NE.nub lus
|
||||
(iid, inew) <- idAndNew <$> insertBy' (Instance h)
|
||||
if inew
|
||||
then return ((iid, h), (Nothing, Just lus'))
|
||||
else do
|
||||
es <- for lus' $ \ lu -> do
|
||||
mers <- getBy $ UniqueRemoteSharer iid lu
|
||||
return $
|
||||
case mers of
|
||||
Just (Entity rsid rs) -> Left (rsid, remoteSharerInbox rs)
|
||||
Nothing -> Right lu
|
||||
let (newKnown, unknown) = partitionEithers $ NE.toList es
|
||||
return ((iid, h), (nonEmpty newKnown, nonEmpty unknown))
|
||||
let moreKnown = mapMaybe (\ (i, (k, _)) -> (i,) <$> k) recips'
|
||||
stillUnknown = mapMaybe (\ (i, (_, u)) -> (i,) <$> u) recips'
|
||||
-- ^ [ ( (iid, h) , NonEmpty luActor ) ]
|
||||
-- TODO see the earlier TODO about merge, it applies here too
|
||||
allKnown = map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat known moreKnown
|
||||
-- ^ [ ( (iid, h) , NonEmpty (rsid, inb) ) ]
|
||||
error "TODO CONTINUE"
|
||||
where
|
||||
groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
|
||||
groupByHost = groupAllExtract furiHost (snd . f2l)
|
||||
|
|
|
|||
|
|
@ -48,6 +48,8 @@ module Vervis.Handler.Ticket
|
|||
, postTicketDepR
|
||||
, deleteTicketDepR
|
||||
, getTicketReverseDepsR
|
||||
, getTicketParticipantsR
|
||||
, getTicketTeamR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -767,3 +769,9 @@ deleteTicketDepR shr prj pnum cnum = do
|
|||
|
||||
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketReverseDepsR = getTicketDeps False
|
||||
|
||||
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||||
getTicketParticipantsR = error "TODO implement getTicketParticipantsR"
|
||||
|
||||
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||||
getTicketTeamR = error "TODO implement getTicketTeamR"
|
||||
|
|
|
|||
|
|
@ -237,6 +237,8 @@ changes =
|
|||
"LocalMessage"
|
||||
(Nothing :: Maybe Text)
|
||||
"unlinkedParent"
|
||||
-- 55
|
||||
, addEntities model_2019_04_11
|
||||
]
|
||||
|
||||
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ module Vervis.Migration.Model
|
|||
, FollowerSet2019Generic (..)
|
||||
, FollowerSet2019
|
||||
, Ticket2019
|
||||
, model_2019_04_11
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -91,3 +92,6 @@ model_2019_03_30 = $(schema "2019_03_30")
|
|||
|
||||
makeEntitiesMigration "2019"
|
||||
$(modelFile "migrations/2019_03_30_follower_set.model")
|
||||
|
||||
model_2019_04_11 :: [Entity SqlBackend]
|
||||
model_2019_04_11 = $(schema "2019_04_11")
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ import Web.PathPieces.Local ()
|
|||
|
||||
newtype ShrIdent = ShrIdent { unShrIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
shr2text :: ShrIdent -> Text
|
||||
shr2text = CI.original . unShrIdent
|
||||
|
|
@ -71,7 +71,7 @@ text2shr = ShrIdent . CI.mk
|
|||
|
||||
newtype KyIdent = KyIdent { unKyIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
ky2text :: KyIdent -> Text
|
||||
ky2text = CI.original . unKyIdent
|
||||
|
|
@ -81,7 +81,7 @@ text2ky = KyIdent . CI.mk
|
|||
|
||||
newtype RlIdent = RlIdent { unRlIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
rl2text :: RlIdent -> Text
|
||||
rl2text = CI.original . unRlIdent
|
||||
|
|
@ -91,7 +91,7 @@ text2rl = RlIdent . CI.mk
|
|||
|
||||
newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
prj2text :: PrjIdent -> Text
|
||||
prj2text = CI.original . unPrjIdent
|
||||
|
|
@ -101,7 +101,7 @@ text2prj = PrjIdent . CI.mk
|
|||
|
||||
newtype RpIdent = RpIdent { unRpIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
rp2text :: RpIdent -> Text
|
||||
rp2text = CI.original . unRpIdent
|
||||
|
|
@ -111,7 +111,7 @@ text2rp = RpIdent . CI.mk
|
|||
|
||||
newtype WflIdent = WflIdent { unWflIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
wfl2text :: WflIdent -> Text
|
||||
wfl2text = CI.original . unWflIdent
|
||||
|
|
@ -121,7 +121,7 @@ text2wfl = WflIdent . CI.mk
|
|||
|
||||
newtype FldIdent = FldIdent { unFldIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
fld2text :: FldIdent -> Text
|
||||
fld2text = CI.original . unFldIdent
|
||||
|
|
@ -131,7 +131,7 @@ text2fld = FldIdent . CI.mk
|
|||
|
||||
newtype EnmIdent = EnmIdent { unEnmIdent :: CI Text }
|
||||
deriving
|
||||
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
(Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
|
||||
|
||||
enm2text :: EnmIdent -> Text
|
||||
enm2text = CI.original . unEnmIdent
|
||||
|
|
|
|||
|
|
@ -29,8 +29,11 @@ where
|
|||
import Prelude
|
||||
|
||||
import Control.Concurrent.MVar (MVar, newMVar)
|
||||
import Control.Concurrent.ResultShare
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.STM
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Foldable
|
||||
|
|
@ -43,10 +46,11 @@ import Database.Persist
|
|||
import Database.Persist.Sql
|
||||
import Network.HTTP.Client
|
||||
import UnliftIO.MVar (withMVar)
|
||||
import Yesod.Core
|
||||
import Yesod.Core hiding (logError)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Crypto.PublicVerifKey
|
||||
import Database.Persist.Local
|
||||
|
|
@ -74,6 +78,8 @@ class Yesod site => YesodRemoteActorStore site where
|
|||
siteActorRoomMode :: site -> Maybe Int
|
||||
siteRejectOnMaxKeys :: site -> Bool
|
||||
|
||||
siteActorFetchShare :: site -> ResultShare (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId
|
||||
|
||||
-- TODO this is copied from stm-2.5, remove when we upgrade LTS
|
||||
stateTVar :: TVar s -> (s -> (a, s)) -> STM a
|
||||
stateTVar var f = do
|
||||
|
|
@ -438,3 +444,40 @@ addVerifKey h uinb vkd =
|
|||
else when (inew == Just False) $ lift $ makeActorRoomForPersonalKey limit rsid
|
||||
lift $ insert_ $ VerifKey luKey iid mexpires key (Just rsid)
|
||||
return (iid, rsid)
|
||||
|
||||
actorFetchShareSettings
|
||||
:: ( YesodPersist site
|
||||
, PersistUniqueRead (YesodPersistBackend site)
|
||||
, PersistStoreWrite (YesodPersistBackend site)
|
||||
, BaseBackend (YesodPersistBackend site) ~ SqlBackend
|
||||
, HasHttpManager site
|
||||
)
|
||||
=> ResultShareSettings (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId
|
||||
actorFetchShareSettings = ResultShareSettings
|
||||
{ resultShareFork = forkHandler $ \ e -> logError $ "ActorFetchShare action failed! " <> T.pack (displayException e)
|
||||
, resultShareAction = \ u iid -> do
|
||||
let (h, lu) = f2l u
|
||||
mers <- runDB $ getBy $ UniqueRemoteSharer iid lu
|
||||
case mers of
|
||||
Just ers -> return $ Right ers
|
||||
Nothing -> do
|
||||
manager <- getsYesod getHttpManager
|
||||
eactor <- fetchAPID manager actorId h lu
|
||||
for eactor $ \ actor -> runDB $
|
||||
insertEntity $ RemoteSharer lu iid (actorInbox actor)
|
||||
}
|
||||
|
||||
fetchRemoteActor
|
||||
:: ( YesodPersist site
|
||||
, PersistUniqueRead (YesodPersistBackend site)
|
||||
, BaseBackend (YesodPersistBackend site) ~ SqlBackend
|
||||
, YesodRemoteActorStore site
|
||||
)
|
||||
=> InstanceId -> Text -> LocalURI -> HandlerFor site (Either String (Entity RemoteSharer))
|
||||
fetchRemoteActor iid host luActor = do
|
||||
mers <- runDB $ getBy $ UniqueRemoteSharer iid luActor
|
||||
case mers of
|
||||
Just ers -> return $ Right ers
|
||||
Nothing -> do
|
||||
afs <- getsYesod siteActorFetchShare
|
||||
runShared afs (l2f host luActor) iid
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@ flag library-only
|
|||
library
|
||||
exposed-modules: Control.Applicative.Local
|
||||
Control.Concurrent.Local
|
||||
Control.Concurrent.ResultShare
|
||||
Crypto.PubKey.Encoding
|
||||
Crypto.PublicVerifKey
|
||||
Darcs.Local.Repository
|
||||
|
|
@ -65,6 +66,7 @@ library
|
|||
Data.Int.Local
|
||||
Data.KeyFile
|
||||
Data.List.Local
|
||||
Data.List.NonEmpty.Local
|
||||
Data.Maybe.Local
|
||||
Data.Paginate.Local
|
||||
Data.Text.UTF8.Local
|
||||
|
|
@ -252,6 +254,7 @@ library
|
|||
, data-default
|
||||
, data-default-class
|
||||
, data-default-instances-bytestring
|
||||
, data-ordlist
|
||||
-- for drawing DAGs: RBAC role inheritance, etc.
|
||||
, diagrams-core
|
||||
, diagrams-lib
|
||||
|
|
|
|||
Loading…
Reference in a new issue