sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:04:52 +09:00
Code Issues Activity

Add field localMessageCreate, pointing to the OutboxItem that created it

Browse source 
I added a migration that creates an ugly fake OutboxItem for messages that
don't have one. I'll try to turn it into a real one. And then very possibly
remove the whole ugly migration, replacing it with addFielfRefRequiredEmpty,
which should work for empty instances.
This commit is contained in:
fr33domlover 2019-05-25 03:23:57 +00:00
parent d77877eba5
commit e81eb80b8b
7 changed files with 173 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

@ -328,6 +328,7 @@ Message
LocalMessage
author PersonId
rest MessageId
create OutboxItemId
unlinkedParent FedURI Maybe
UniqueLocalMessage rest

43
migrations/2019_05_24.model Normal file
View file

@ -0,0 +1,43 @@
Sharer
ident ShrIdent
name Text Maybe
created UTCTime
UniqueSharer ident
Person
ident SharerId
login Text
passphraseHash ByteString
email Text
verified Bool
verifiedKey Text
verifiedKeyCreated UTCTime
resetPassKey Text
resetPassKeyCreated UTCTime
about Text
UniquePersonIdent ident
UniquePersonLogin login
UniquePersonEmail email
OutboxItem
person PersonId
activity PersistJSONValue
published UTCTime
Discussion
Message
created UTCTime
content Text -- Assume this is Pandoc Markdown
parent MessageId Maybe
root DiscussionId
LocalMessage
author PersonId
rest MessageId
create OutboxItemId
unlinkedParent Text Maybe
UniqueLocalMessage rest

2
src/Vervis/Application.hs
View file

@ -171,7 +171,7 @@ makeFoundation appSettings = do
--runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
flip runLoggingT logFunc $
flip runSqlPool pool $ do
r <- migrateDB
r <- migrateDB hashidsCtx
case r of
Left err -> do
let msg = "DB migration failed: " <> err

31
src/Vervis/Federation.hs
View file

@ -1334,23 +1334,13 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
_ -> 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
let activity luAct luNote = Doc host Activity
{ activityId = luAct
, activityActor = luAttrib
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note
{ noteId = Just $ route2local $ MessageR shrUser lmhid
{ noteId = Just luNote
, noteAttrib = luAttrib
, noteAudience = aud
, noteReplyTo = Just $ fromMaybe uContext muParent
@ -1360,14 +1350,27 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
}
}
}
tempUri = LocalURI "" ""
obid <- insert OutboxItem
{ outboxItemPerson = pid
, outboxItemActivity = PersistJSON $ activity $ LocalURI "" ""
, outboxItemActivity = PersistJSON $ activity tempUri tempUri
, outboxItemPublished = now
}
lmid <- insert LocalMessage
{ localMessageAuthor = pid
, localMessageRest = mid
, localMessageCreate = obid
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
route2local <- getEncodeRouteLocal
obhid <- encodeKeyHashid obid
lmhid <- encodeKeyHashid lmid
let luAct = route2local $ OutboxItemR shrUser obhid
doc = activity luAct
luNote = route2local $ MessageR shrUser lmhid
doc = activity luAct luNote
update obid [OutboxItemActivity =. PersistJSON doc]
return (lmid, obid, doc)

103
src/Vervis/Migration.hs
View file

@ -21,19 +21,19 @@ where
import Prelude
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.ByteString (ByteString)
import Data.Default.Class
import Data.Default.Instances.ByteString ()
import Data.Foldable (traverse_, for_)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Clock
import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.Migration
@ -43,12 +43,23 @@ import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey)
--import Text.Email.QuasiQuotation (email
import Text.Email.Validate (unsafeEmailAddress)
import Web.Hashids
import Web.PathPieces (toPathPiece)
import qualified Data.Aeson as A
import qualified Database.Esqueleto as E
import qualified Database.Persist.Schema as S
import qualified Database.Persist.Schema.Types as ST
import Network.FedURI
import Database.Persist.JSON
import Web.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Vervis.Model.Ident
import Vervis.Foundation (Route (..))
import Vervis.Migration.Model
instance PersistDefault ByteString where
@ -66,8 +77,8 @@ withPrepare (validate, apply) prepare = (validate, prepare >> apply)
--withPrePost :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
--withPrePost pre (validate, apply) post = (validate, pre >> apply >> post)
changes :: MonadIO m => [Mig m]
changes =
changes :: MonadIO m => HashidsContext -> [Mig m]
changes ctx =
[ -- 1
addEntities model_2016_08_04
-- 2
@ -280,9 +291,85 @@ changes =
, addFieldPrimOptional "RemoteActor" (Nothing :: Maybe Text) "name"
-- 76
, addFieldPrimRequired "InboxItem" False "unread"
-- 77
, addFieldRefRequired''
"LocalMessage"
(do let user = "$$temp$$"
sid <-
insert $ Sharer201905 (text2shr user) Nothing defaultTime
pid <-
insert $
Person201905
sid user "" "e@ma.il" False "" defaultTime ""
defaultTime ""
let localUri = LocalURI "/x/y" ""
fedUri = l2f "x.y" localUri
d2v = fromJust . A.decode . A.encode
doc = d2v $ Doc "x.y" Activity
{ activityId = localUri
, activityActor = localUri
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = AcceptActivity $ Accept fedUri
}
insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
)
(Just $ \ (Entity obid ob) -> do
let actNoteId (Activity _ _ _ (CreateActivity (Create note))) = noteId note
actNoteId _ = Nothing
obNoteId (Entity i o) =
if i == obid
then Nothing
else (,i) <$> actNoteId (docValue $ fromJust $ A.decode $ A.encode $ persistJSONValue $ outboxItem201905Activity o)
obs <-
mapMaybe obNoteId <$>
selectList ([] :: [Filter OutboxItem201905]) []
lms <- selectList ([] :: [Filter LocalMessage201905]) []
for_ lms $ \ (Entity lmid lm) -> do
let pid = localMessage201905Author lm
p <- getJust pid
s <- getJust $ person201905Ident p
let shr = sharer201905Ident s
route = MessageR shr (encodeKeyHashidPure ctx $ E.toSqlKey $ E.fromSqlKey lmid)
match (luNote, obid') =
case decodeRouteLocal luNote of
Just r@(MessageR _ _) ->
if r == route
then Just obid'
else Nothing
_ -> error "Invalid local luNote"
mobid =
case mapMaybe match obs of
[] -> Nothing
[k] -> Just k
_ -> error "Multiple outbox IDs!"
obidNew <-
case mobid of
Just k -> return k
Nothing -> do
now <- liftIO getCurrentTime
let localUri = LocalURI "/x/y" ""
fedUri = l2f "lo.cal" localUri
d2v = fromJust . A.decode . A.encode
doc = PersistJSON $ d2v $ Doc "lo.cal" Activity
{ activityId = localUri
, activityActor = localUri
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = AcceptActivity $ Accept fedUri
}
insert $ OutboxItem201905 pid doc now
update lmid [LocalMessage201905Create =. obidNew]
delete obid
let pid = outboxItem201905Person ob
p <- getJust pid
delete pid
delete $ person201905Ident p
)
"create"
"OutboxItem"
]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB =
migrateDB :: MonadIO m => HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB ctx =
let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
in f changes
in f $ changes ctx

9
src/Vervis/Migration/Model.hs
View file

@ -40,6 +40,12 @@ module Vervis.Migration.Model
, model_2019_04_22
, model_2019_05_03
, model_2019_05_17
, Sharer201905Generic (..)
, Person201905Generic (..)
, OutboxItem201905Generic (..)
, OutboxItem201905
, LocalMessage201905Generic (..)
, LocalMessage201905
)
where
@ -110,3 +116,6 @@ model_2019_05_03 = $(schema "2019_05_03")
model_2019_05_17 :: [Entity SqlBackend]
model_2019_05_17 = $(schema "2019_05_17")
makeEntitiesMigration "201905"
$(modelFile "migrations/2019_05_24.model")

8
src/Yesod/Hashids.hs
View file

@ -17,6 +17,7 @@ module Yesod.Hashids
( YesodHashids (..)
, KeyHashid ()
, keyHashidText
, encodeKeyHashidPure
, getEncodeKeyHashid
, encodeKeyHashid
, decodeKeyHashidF
@ -54,6 +55,11 @@ instance PersistEntity record => PathPiece (KeyHashid record) where
fromPathPiece t = KeyHashid <$> fromPathPiece t
toPathPiece (KeyHashid t) = toPathPiece t
encodeKeyHashidPure
:: ToBackendKey SqlBackend record
=> HashidsContext -> Key record -> KeyHashid record
encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
getEncodeKeyHashid
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
@ -62,7 +68,7 @@ getEncodeKeyHashid
=> m (Key record -> KeyHashid record)
getEncodeKeyHashid = do
ctx <- getsYesod siteHashidsContext
return $ KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
return $ encodeKeyHashidPure ctx
encodeKeyHashid
:: ( MonadHandler m