diff --git a/migrations/2019_05_24.model b/migrations/2019_05_24.model index 7421bd4..03e37ee 100644 --- a/migrations/2019_05_24.model +++ b/migrations/2019_05_24.model @@ -23,7 +23,7 @@ Person OutboxItem person PersonId - activity PersistJSONValue + activity PersistActivity published UTCTime Discussion @@ -38,6 +38,61 @@ LocalMessage author PersonId rest MessageId create OutboxItemId - unlinkedParent Text Maybe + unlinkedParent FedURI Maybe UniqueLocalMessage rest + +Instance + host Text + + UniqueInstance host + +RemoteDiscussion + instance InstanceId + ident LocalURI + discuss DiscussionId + + UniqueRemoteDiscussionIdent instance ident + UniqueRemoteDiscussion discuss + +Ticket + project ProjectId + number Int + created UTCTime + creator PersonId + title Text + desc Text -- Assume this is Pandoc Markdown + assignee PersonId Maybe + status Text + closed UTCTime + closer PersonId + discuss DiscussionId + followers Int64 + + UniqueTicket project number + UniqueTicketDiscussion discuss + UniqueTicketFollowers followers + +Project + ident PrjIdent + sharer SharerId + name Text Maybe + desc Text Maybe + workflow Int64 + nextTicket Int + wiki Int64 Maybe + collabUser Int64 Maybe + collabAnon Int64 Maybe + + UniqueProject ident sharer + +RemoteMessage + author Int64 + instance InstanceId + ident LocalURI + rest MessageId + create Int64 + lostParent FedURI Maybe + + UniqueRemoteMessageIdent instance ident + UniqueRemoteMessage rest diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 85b08eb..8fe1a06 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -171,7 +171,8 @@ makeFoundation appSettings = do --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc flip runLoggingT logFunc $ flip runSqlPool pool $ do - r <- migrateDB hashidsCtx + let hLocal = appInstanceHost appSettings + r <- migrateDB hLocal hashidsCtx case r of Left err -> do let msg = "DB migration failed: " <> err diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2d972a0..a7515ff 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -20,9 +20,11 @@ where import Prelude +import Control.Applicative import Control.Monad (unless) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.ByteString (ByteString) import Data.Default.Class @@ -46,7 +48,7 @@ import Text.Email.Validate (unsafeEmailAddress) import Web.Hashids import Web.PathPieces (toPathPiece) -import qualified Data.Aeson as A +import qualified Data.Text as T import qualified Database.Esqueleto as E import qualified Database.Persist.Schema as S @@ -58,6 +60,8 @@ import Web.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Database.Persist.Local + import Vervis.Model.Ident import Vervis.Foundation (Route (..)) import Vervis.Migration.Model @@ -77,8 +81,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 => HashidsContext -> [Mig m] -changes ctx = +changes :: MonadIO m => Text -> HashidsContext -> [Mig m] +changes hLocal ctx = [ -- 1 addEntities model_2016_08_04 -- 2 @@ -304,8 +308,7 @@ changes ctx = defaultTime "" let localUri = LocalURI "/x/y" "" fedUri = l2f "x.y" localUri - d2v = fromJust . A.decode . A.encode - doc = d2v $ Doc "x.y" Activity + doc = Doc "x.y" Activity { activityId = localUri , activityActor = localUri , activityAudience = Audience [] [] [] [] [] [] @@ -319,7 +322,7 @@ changes ctx = obNoteId (Entity i o) = if i == obid then Nothing - else (,i) <$> actNoteId (docValue $ fromJust $ A.decode $ A.encode $ persistJSONValue $ outboxItem201905Activity o) + else (,i) <$> actNoteId (docValue $ persistJSONValue $ outboxItem201905Activity o) obs <- mapMaybe obNoteId <$> selectList ([] :: [Filter OutboxItem201905]) [] @@ -346,17 +349,119 @@ changes ctx = 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 + -- Figure out: + -- * aud + -- * uContext + -- * muParent + m <- getJust $ localMessage201905Rest lm + + let did = message201905Root m + mcontext <- + runMaybeT + $ Left <$> MaybeT (getValBy $ UniqueTicketDiscussion201905 did) + <|> Right <$> MaybeT (getValBy $ UniqueRemoteDiscussion201905 did) + let context = + case mcontext of + Nothing -> error "DiscussionId not used" + Just c -> c + (uContext, recips) <- + case context of + Left t -> do + j <- getJust $ ticket201905Project t + let tprj = project201905Ident j + s <- getJust $ project201905Sharer j + let tshr = sharer201905Ident s + jPath = T.concat + [ "/s/", shr2text tshr + , "/p/", prj2text tprj + ] + tPath = T.concat + [ jPath + , "/t/", T.pack $ show $ ticket201905Number t + ] + return + ( FedURI hLocal tPath "" + , map (l2f hLocal . flip LocalURI "") + [ jPath + , tPath <> "/participants" + , tPath <> "/team" + ] + ) + Right rd -> do + i <- getJust $ + remoteDiscussion201905Instance rd + return + ( l2f + (instance201905Host i) + (remoteDiscussion201905Ident rd) + , [] + ) + + -- parent + muParent <- + case Left <$> localMessage201905UnlinkedParent lm <|> + Right <$> message201905Parent m of + Nothing -> return Nothing + Just (Left fu) -> return $ Just fu + Just (Right midParent) -> Just <$> do + mparent <- + runMaybeT + $ Left <$> MaybeT (getBy $ UniqueLocalMessage201905 midParent) + <|> Right <$> MaybeT (getValBy $ UniqueRemoteMessage201905 midParent) + case fromJust mparent of + Left (Entity lmidP lmP) -> do + p <- getJust $ localMessage201905Author lmP + s <- getJust $ person201905Ident p + let path = T.concat + [ "/s/", shr2text $ sharer201905Ident s + , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP + ] + return $ FedURI hLocal path "" + Right rmP -> do + i <- getJust $ + remoteMessage201905Instance rmP + return $ + l2f (instance201905Host i) + (remoteMessage201905Ident rmP) + + let aud = Audience recips [] [] [] [] [] + + luAttrib = LocalURI ("/s/" <> shr2text shr) "" + activity luAct luNote = Doc hLocal Activity + { activityId = luAct + , activityActor = luAttrib + , activityAudience = aud + , activitySpecific = CreateActivity Create + { createObject = Note + { noteId = Just luNote + , noteAttrib = luAttrib + , noteAudience = aud + , noteReplyTo = Just $ fromMaybe uContext muParent + , noteContext = Just uContext + , notePublished = Just $ message201905Created m + , noteContent = message201905Content m + } + } } - insert $ OutboxItem201905 pid doc now + tempUri = LocalURI "" "" + newObid <- insert OutboxItem201905 + { outboxItem201905Person = pid + , outboxItem201905Activity = PersistJSON $ activity tempUri tempUri + , outboxItem201905Published = message201905Created m + } + let notePath = T.concat + [ "/s/", shr2text shr + , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmid + ] + obPath = T.concat + [ "/s/", shr2text shr + , "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid + ] + luAct = LocalURI obPath "" + luNote = LocalURI notePath "" + doc = activity luAct luNote + update newObid [OutboxItem201905Activity =. PersistJSON doc] + return newObid update lmid [LocalMessage201905Create =. obidNew] delete obid @@ -369,7 +474,7 @@ changes ctx = "OutboxItem" ] -migrateDB :: MonadIO m => HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) -migrateDB ctx = +migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) +migrateDB hLocal ctx = let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs - in f $ changes ctx + in f $ changes hLocal ctx diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 19725e4..7acda20 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -15,6 +15,7 @@ module Vervis.Migration.Model ( EntityField (..) + , Unique (..) , model_2016_08_04 , model_2016_09_01_just_workflow , Sharer2016 @@ -46,6 +47,12 @@ module Vervis.Migration.Model , OutboxItem201905 , LocalMessage201905Generic (..) , LocalMessage201905 + , Message201905Generic (..) + , Project201905Generic (..) + , Ticket201905Generic (..) + , Instance201905Generic (..) + , RemoteDiscussion201905Generic (..) + , RemoteMessage201905Generic (..) ) where @@ -54,7 +61,7 @@ import Prelude import Data.ByteString (ByteString) import Data.Text (Text) import Data.Time (UTCTime) -import Database.Persist.Class (EntityField) +import Database.Persist.Class (EntityField, Unique) import Database.Persist.JSON (PersistJSONValue) import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.SQL () @@ -69,6 +76,16 @@ import Vervis.Model.Role import Vervis.Model.TH (modelFile, makeEntitiesMigration) import Vervis.Model.Workflow +-- For migration 77 + +import Data.Int + +import Database.Persist.JSON +import Network.FedURI +import Web.ActivityPub + +type PersistActivity = PersistJSON (Doc Activity) + model_2016_08_04 :: [Entity SqlBackend] model_2016_08_04 = $(schema "2016_08_04")