Generate an Offer Ticket for every ticket, including project inbox item

CRITICAL: Due to the requirement that each new ticket points to its Offer
activity, ticket creation has been disabled! The next patches should implement
C2S submission of Offer Ticket, and then ticket creation will work again. Sorry
for that.

config/models

@@ -306,8 +306,10 @@ Ticket
 TicketAuthorLocal
     ticket TicketId
     author PersonId
+    offer  OutboxItemId
 
     UniqueTicketAuthorLocal ticket
+    UniqueTicketAuthorLocalOffer offer
 
 TicketAuthorRemote
     ticket TicketId

migrations/2019_06_12.model

@@ -0,0 +1,84 @@
+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
+    inbox               InboxId
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+
+OutboxItem
+    person    PersonId
+    activity  PersistActivity
+    published UTCTime
+
+Inbox
+
+InboxItem
+    unread Bool
+
+InboxItemLocal
+    inbox    InboxId
+    activity OutboxItemId
+    item     InboxItemId
+
+    UniqueInboxItemLocal inbox activity
+    UniqueInboxItemLocalItem item
+
+Project
+    ident      PrjIdent
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   Int64
+    nextTicket Int
+    wiki       Int64         Maybe
+    collabUser Int64         Maybe
+    collabAnon Int64         Maybe
+    inbox      InboxId
+    followers  Int64
+
+    UniqueProject ident sharer
+    UniqueProjectInbox inbox
+    UniqueProjectFollowers followers
+
+Ticket
+    project     ProjectId
+    number      Int
+    created     UTCTime
+    title       Text
+    source      Text                -- Pandoc Markdown
+    description Text                -- HTML
+    assignee    PersonId      Maybe
+    status      Text
+    closed      UTCTime
+    closer      PersonId      Maybe
+    discuss     Int64
+    followers   Int64
+
+    UniqueTicket project number
+    UniqueTicketDiscussion discuss
+    UniqueTicketFollowers followers
+
+TicketAuthorLocal
+    ticket TicketId
+    author PersonId
+    offer  OutboxItemId
+
+    UniqueTicketAuthorLocal ticket

src/Vervis/Handler/Ticket.hs

@@ -177,7 +177,7 @@ postTicketsR shar proj = do
                         , ticketFollowers   = fsid
                         }
                 tid <- insert ticket
-                insert_ $ TicketAuthorLocal tid author
+                insert_ $ TicketAuthorLocal tid author $ error "TODO offer"
                 let mktparam (fid, v) = TicketParamText
                         { ticketParamTextTicket = tid
                         , ticketParamTextField  = fid

src/Vervis/Migration.hs

@@ -46,12 +46,15 @@ import Database.Persist.Schema (SchemaT, Migration)
 import Database.Persist.Schema.Types hiding (Entity)
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Database.Persist.Sql (SqlBackend, toSqlKey)
+import Text.Blaze.Html (toHtml)
+import Text.Blaze.Html.Renderer.Text
 --import Text.Email.QuasiQuotation (email
 import Text.Email.Validate (unsafeEmailAddress)
 import Web.Hashids
 import Web.PathPieces (toPathPiece)
 
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
 
 import qualified Database.Persist.Schema as S
@@ -68,7 +71,7 @@ import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.Model.Ident
-import Vervis.Foundation (Route (..))
+import Vervis.Foundation (App, Route (..))
 import Vervis.Migration.Model
 import Yesod.RenderSource
 
@@ -87,7 +90,7 @@ 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 :: MonadSite m => Text -> HashidsContext -> [Mig m]
+changes :: (MonadSite m, SiteEnv m ~ App) => Text -> HashidsContext -> [Mig m]
 changes hLocal ctx =
     [ -- 1
       addEntities model_2016_08_04
@@ -355,10 +358,6 @@ changes hLocal ctx =
                     case mobid of
                         Just k -> return k
                         Nothing -> do
-                            -- Figure out:
-                            --   * aud
-                            --   * uContext
-                            --   * muParent
                             m <- getJust $ localMessage201905Rest lm
 
                             let did = message201905Root m
@@ -669,10 +668,114 @@ changes hLocal ctx =
       -- 113
     , addUnique "TicketAuthorRemote" $
         Unique "UniqueTicketAuthorRemoteOffer" ["offer"]
+      -- 114
+    , addFieldRefRequired''
+        "TicketAuthorLocal"
+        (do let user = "$$temp$$"
+            sid <-
+                insert $ Sharer20190612 (text2shr user) Nothing defaultTime
+            ibid <- insert Inbox20190612
+            pid <-
+                insert $
+                    Person20190612
+                        sid user "" "e@ma.il" False "" defaultTime ""
+                        defaultTime "" ibid
+            let localUri = LocalURI "/x/y" ""
+                fedUri = l2f "x.y" localUri
+                doc = Doc "x.y" Activity
+                    { activityId       = localUri
+                    , activityActor    = localUri
+                    , activityAudience = Audience [] [] [] [] [] []
+                    , activitySpecific = AcceptActivity $ Accept fedUri
+                    }
+            insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime
+        )
+        (Just $ \ (Entity obidTemp obTemp) -> do
+            ts <- selectList ([] :: [Filter Ticket20190612]) []
+            for_ ts $ \ (Entity tid ticket) -> do
+                let num = ticket20190612Number ticket
+                j <- getJust $ ticket20190612Project ticket
+                let prj = project20190612Ident j
+                    ibidProject = project20190612Inbox j
+                sProject <- getJust $ project20190612Sharer j
+                let shrProject = sharer20190612Ident sProject
+
+                Entity talid tal <-
+                    fromJust <$> getBy (UniqueTicketAuthorLocal20190612 tid)
+                let pidAuthor = ticketAuthorLocal20190612Author tal
+                pAuthor <- getJust pidAuthor
+                sAuthor <- getJust $ person20190612Ident pAuthor
+                let shrAuthor = sharer20190612Ident sAuthor
+
+                encodeRouteLocal <- getEncodeRouteLocal
+                encodeRouteHome <- getEncodeRouteHome
+                let recips = map encodeRouteHome
+                        [ ProjectR shrProject prj
+                        , ProjectTeamR shrProject prj
+                        , ProjectFollowersR shrProject prj
+                        ]
+                    author = encodeRouteLocal $ SharerR shrAuthor
+                    ticketAP = Ticket
+                        { ticketLocal        = Nothing
+                        , ticketAttributedTo = author
+                        , ticketPublished    =
+                            Just $ ticket20190612Created ticket
+                        , ticketUpdated      = Nothing
+                        , ticketName         = Just $ "#" <> T.pack (show num)
+                        , ticketSummary      =
+                            TextHtml $ TL.toStrict $ renderHtml $ toHtml $
+                                ticket20190612Title ticket
+                        , ticketContent      =
+                            TextHtml $ ticket20190612Description ticket
+                        , ticketSource       =
+                            TextPandocMarkdown $ ticket20190612Source ticket
+                        , ticketAssignedTo   = Nothing
+                        , ticketIsResolved   = False
+                        , ticketDependsOn    = []
+                        , ticketDependedBy   = []
+                        }
+                    doc luAct = Doc hLocal Activity
+                        { activityId       = luAct
+                        , activityActor    = author
+                        , activityAudience = Audience recips [] [] [] [] []
+                        , activitySpecific = OfferActivity Offer
+                            { offerObject = ticketAP
+                            , offerTarget =
+                                encodeRouteHome $ ProjectR shrProject prj
+                            }
+                        }
+                    tempUri = LocalURI "" ""
+                obidNew <- insert OutboxItem20190612
+                    { outboxItem20190612Person    = pidAuthor
+                    , outboxItem20190612Activity  = PersistJSON $ doc tempUri
+                    , outboxItem20190612Published =
+                        ticket20190612Created ticket
+                    }
+                obkhidNew <-
+                    encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obidNew
+                let luAct = encodeRouteLocal $ OutboxItemR shrAuthor obkhidNew
+                    act = doc luAct
+                update obidNew [OutboxItem20190612Activity =. PersistJSON act]
+                update talid [TicketAuthorLocal20190612Offer =. obidNew]
+                ibiid <- insert $ InboxItem20190612 False
+                insert_ $ InboxItemLocal20190612 ibidProject obidNew ibiid
+
+            delete obidTemp
+            let pidTemp = outboxItem20190612Person obTemp
+            pTemp <- getJust pidTemp
+            delete pidTemp
+            delete $ person20190612Ident pTemp
+            delete $ person20190612Inbox pTemp
+        )
+        "offer"
+        "OutboxItem"
+      -- 115
+    , addUnique "TicketAuthorLocal" $
+        Unique "UniqueTicketAuthorLocaleOffer" ["offer"]
     ]
 
 migrateDB
-    :: MonadSite m
+    :: (MonadSite m, SiteEnv m ~ App)
     => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
 migrateDB hLocal ctx =
     let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs

src/Vervis/Migration/Model.hs

@@ -81,6 +81,16 @@ module Vervis.Migration.Model
     , RemoteMessage2019FillGeneric (..)
     , FollowerSet20190610Generic (..)
     , Project20190610
+    , Sharer20190612Generic (..)
+    , Person20190612Generic (..)
+    , OutboxItem20190612Generic (..)
+    , Inbox20190612Generic (..)
+    , InboxItem20190612Generic (..)
+    , InboxItemLocal20190612Generic (..)
+    , Project20190612Generic (..)
+    , Ticket20190612Generic (..)
+    , Ticket20190612
+    , TicketAuthorLocal20190612Generic (..)
     )
 where
 
@@ -104,7 +114,7 @@ import Vervis.Model.Role
 import Vervis.Model.TH (modelFile, makeEntitiesMigration)
 import Vervis.Model.Workflow
 
--- For migration 77
+-- For migrations 77, 114
 
 import Data.Int
 
@@ -188,3 +198,6 @@ makeEntitiesMigration "2019Fill"
 
 makeEntitiesMigration "20190610"
     $(modelFile "migrations/2019_06_10.model")
+
+makeEntitiesMigration "20190612"
+    $(modelFile "migrations/2019_06_12.model")