diff --git a/config/models b/config/models index c6fbf0c..ac1d7e3 100644 --- a/config/models +++ b/config/models @@ -328,6 +328,7 @@ Message LocalMessage author PersonId rest MessageId + create OutboxItemId unlinkedParent FedURI Maybe UniqueLocalMessage rest diff --git a/migrations/2019_05_24.model b/migrations/2019_05_24.model new file mode 100644 index 0000000..7421bd4 --- /dev/null +++ b/migrations/2019_05_24.model @@ -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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 254c92f..85b08eb 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index c15a1bb..fe6c3e6 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 01dfc6f..2d972a0 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 7ccd016..19725e4 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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") diff --git a/src/Yesod/Hashids.hs b/src/Yesod/Hashids.hs index 982c1e8..eb814be 100644 --- a/src/Yesod/Hashids.hs +++ b/src/Yesod/Hashids.hs @@ -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