diff --git a/config/models b/config/models index f86b1e3..fe9cefd 100644 --- a/config/models +++ b/config/models @@ -48,6 +48,12 @@ OutboxItem activity PersistActivity published UTCTime +InboxItemLocal + person PersonId + activity OutboxItemId + + UniqueInboxItemLocal person activity + VerifKey ident LocalURI instance InstanceId diff --git a/config/routes b/config/routes index 5a627f0..452369f 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/migrations/2019_04_11.model b/migrations/2019_04_11.model new file mode 100644 index 0000000..23f84bb --- /dev/null +++ b/migrations/2019_04_11.model @@ -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 diff --git a/src/Control/Concurrent/ResultShare.hs b/src/Control/Concurrent/ResultShare.hs new file mode 100644 index 0000000..901d972 --- /dev/null +++ b/src/Control/Concurrent/ResultShare.hs @@ -0,0 +1,97 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs index 14eb7c7..4abb3be 100644 --- a/src/Data/List/Local.hs +++ b/src/Data/List/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Data/List/NonEmpty/Local.hs b/src/Data/List/NonEmpty/Local.hs new file mode 100644 index 0000000..b9dd958 --- /dev/null +++ b/src/Data/List/NonEmpty/Local.hs @@ -0,0 +1,60 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Data/Maybe/Local.hs b/src/Data/Maybe/Local.hs index c361164..5e6bfa5 100644 --- a/src/Data/Maybe/Local.hs +++ b/src/Data/Maybe/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index 20bc02f..561fe48 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -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) diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index cbede6f..52a1644 100644 --- a/src/Network/FedURI.hs +++ b/src/Network/FedURI.hs @@ -13,6 +13,8 @@ - . -} +{-# 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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 30bbe74..c72afbd 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 149601d..5427c7a 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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" diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 821a22d..853d85d 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index b67ff14..6af2f74 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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") diff --git a/src/Vervis/Model/Ident.hs b/src/Vervis/Model/Ident.hs index 940ec7b..ce41d7a 100644 --- a/src/Vervis/Model/Ident.hs +++ b/src/Vervis/Model/Ident.hs @@ -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 diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 6de704e..919d469 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -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 diff --git a/vervis.cabal b/vervis.cabal index ca8e034..c09b0d9 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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