Complete DB migration list, allowing to upgrade 2016-08-04 running instance

Until now the list of DB migration actions was incomplete, containing only
changes made since I added the migration system itself. It now contains the
2016-08-04 model, and then every change made since then.

IMPORTANT: The 2016-08-04 instance doesn't have a schema version entity at all,
so it is assigned version 0, while the actual version of its schema is 1. I'm
going to patch persistent-migration to allow it to be 1, making the migration
path smooth.

migrations/2016_08_04.model

@@ -0,0 +1,196 @@
+-- This file is part of Vervis.
+--
+-- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+--
+-- ♡ 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
+-- <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+-------------------------------------------------------------------------------
+-- People
+-------------------------------------------------------------------------------
+
+Sharer
+    ident   ShrIdent
+    name    Text     Maybe
+    created UTCTime        default=now()
+
+    UniqueSharer ident
+
+Person
+    ident SharerId
+    login Text
+    hash  Text     Maybe
+    email Text     Maybe
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+
+SshKey
+    ident   KyIdent
+    person  PersonId
+    algo    ByteString
+    content ByteString
+
+    UniqueSshKey person ident
+
+Group
+    ident SharerId
+
+    UniqueGroup ident
+
+GroupMember
+    person PersonId
+    group  GroupId
+    role   GroupRole
+    joined UTCTime
+
+    UniqueGroupMember person group
+
+RepoRole
+    ident  RlIdent
+    sharer SharerId
+    desc   Text
+
+    UniqueRepoRole sharer ident
+
+RepoRoleInherit
+    parent RepoRoleId
+    child  RepoRoleId
+
+    UniqueRepoRoleInherit parent child
+
+RepoAccess
+    role RepoRoleId
+    op   RepoOperation
+
+    UniqueRepoAccess role op
+
+RepoCollab
+    repo   RepoId
+    person PersonId
+    role   RepoRoleId
+
+    UniqueRepoCollab repo person
+
+RepoCollabAnon
+    repo RepoId
+    role RepoRoleId
+
+    UniqueRepoCollabAnon repo
+
+RepoCollabUser
+    repo RepoId
+    role RepoRoleId
+
+    UniqueRepoCollabUser repo
+
+ProjectRole
+    ident  RlIdent
+    sharer SharerId
+    desc   Text
+
+    UniqueProjectRole sharer ident
+
+ProjectRoleInherit
+    parent ProjectRoleId
+    child  ProjectRoleId
+
+    UniqueProjectRoleInherit parent child
+
+ProjectAccess
+    role ProjectRoleId
+    op   ProjectOperation
+
+    UniqueProjectAccess role op
+
+ProjectCollab
+    project ProjectId
+    person  PersonId
+    role    ProjectRoleId
+
+    UniqueProjectCollab project person
+
+ProjectCollabAnon
+    repo ProjectId
+    role ProjectRoleId
+
+    UniqueProjectCollabAnon repo
+
+ProjectCollabUser
+    repo ProjectId
+    role ProjectRoleId
+
+    UniqueProjectCollabUser repo
+
+-------------------------------------------------------------------------------
+-- Projects
+-------------------------------------------------------------------------------
+
+Project
+    ident      PrjIdent
+    sharer     SharerId
+    name       Text     Maybe
+    desc       Text     Maybe
+    nextTicket Int            default=1
+    wiki       RepoId   Maybe
+
+    UniqueProject ident sharer
+
+Repo
+    ident      RpIdent
+    sharer     SharerId
+    vcs        VersionControlSystem       default='VCSGit'
+    project    ProjectId            Maybe
+    desc       Text                 Maybe
+    mainBranch Text                       default='master'
+
+    UniqueRepo ident sharer
+
+Ticket
+    project  ProjectId
+    number   Int
+    created  UTCTime
+    creator  PersonId
+    title    Text
+    desc     Text -- Assume this is Pandoc Markdown
+    assignee PersonId     Maybe
+    done     Bool
+    closed   UTCTime
+    closer   PersonId
+    discuss  DiscussionId
+
+    UniqueTicket project number
+
+TicketDependency
+    parent TicketId
+    child  TicketId
+
+    UniqueTicketDependency parent child
+
+TicketClaimRequest
+    person  PersonId
+    ticket  TicketId
+    message Text     -- Assume this is Pandoc Markdown
+    created UTCTime
+
+    UniqueTicketClaimRequest person ticket
+
+Discussion
+    nextMessage Int
+
+Message
+    author  PersonId
+    created UTCTime
+    content Text               -- Assume this is Pandoc Markdown
+    parent  MessageId    Maybe
+    root    DiscussionId
+    number  Int
+
+    UniqueMessage root number

migrations/2016_09_01_just_workflow.model

@@ -0,0 +1,23 @@
+-- This is in a separate file from the rest of the entities added on the same
+-- day because it is used for creating a dummy public workflow for DB
+-- migrations. Since each project is required to have a workflow, and initially
+-- there's none, we make a dummy one.
+--
+-- Since the 'Sharer' entity isn't defined here, using the Workflow entity
+-- below with the @persistent@ model parser will probably create an 'EntityDef'
+-- in which the sharer field does NOT have a foreign key constraint into the
+-- 'Sharer' table, because the parser won't recognize that 'SharerId' is an
+-- entity ID and not just some other existing type.
+--
+-- However that is okay because we're just using this entity for insertion
+-- once, where we make sure to use a real existing sharer ID, and we also of
+-- course use it for adding the entity to the database schema, but that
+-- mechanism has its own way to detect the foreign keys.
+Workflow
+    sharer SharerId
+    ident  WflIdent
+    name   Text          Maybe
+    desc   Text          Maybe
+    scope  WorkflowScope
+
+    UniqueWorkflow sharer ident

migrations/2016_09_01_rest.model

@@ -0,0 +1,43 @@
+WorkflowField
+    workflow     WorkflowId
+    ident        FldIdent
+    name         Text
+    desc         Text                Maybe
+    type         WorkflowFieldType
+    enm          WorkflowFieldEnumId Maybe
+    required     Bool
+    constant     Bool
+    filterNew    Bool
+    filterTodo   Bool
+    filterClosed Bool
+
+    UniqueWorkflowField workflow ident
+
+WorkflowFieldEnum
+    workflow WorkflowId
+    ident    EnmIdent
+    name     Text
+    desc     Text       Maybe
+
+    UniqueWorkflowFieldEnum workflow ident
+
+WorkflowFieldEnumCtor
+    enum WorkflowFieldEnumId
+    name Text
+    desc Text                Maybe
+
+    UniqueWorkflowFieldEnumCtor enum name
+
+TicketParamText
+    ticket TicketId
+    field  WorkflowFieldId
+    value  Text
+
+    UniqueTicketParamText ticket field
+
+TicketParamEnum
+    ticket TicketId
+    field  WorkflowFieldId
+    value  WorkflowFieldEnumCtorId
+
+    UniqueTicketParamEnum ticket field value

src/Language/Haskell/TH/Quote/Local.hs

@@ -0,0 +1,45 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Language.Haskell.TH.Quote.Local
+    ( expQuasiQuoter
+    , decQuasiQuoter
+    )
+where
+
+import Prelude
+
+import Language.Haskell.TH.Quote (QuasiQuoter (..))
+import Language.Haskell.TH.Syntax (Q, Exp, Dec)
+
+expQuasiQuoter :: (String -> Q Exp) -> QuasiQuoter
+expQuasiQuoter qe = QuasiQuoter
+    { quoteExp  = qe
+    , quotePat  = err
+    , quoteType = err
+    , quoteDec  = err
+    }
+    where
+    err = error "This quasi quoter is only for generating expressions"
+
+decQuasiQuoter :: (String -> Q [Dec]) -> QuasiQuoter
+decQuasiQuoter qd = QuasiQuoter
+    { quoteExp  = err
+    , quotePat  = err
+    , quoteType = err
+    , quoteDec  = qd
+    }
+    where
+    err = error "This quasi quoter is only for generating declarations"

src/Vervis/Migration.hs

@@ -20,48 +20,97 @@ where
 
 import Prelude
 
+import Control.Monad (unless)
 import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Data.ByteString (ByteString)
-import Data.Maybe (fromMaybe)
+import Data.Foldable (traverse_, for_)
+import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Proxy
 import Data.Text (Text)
 import Database.Persist
-import Database.Persist.Sql (SqlBackend, toSqlKey)
-
+import Database.Persist.Migration
 import Database.Persist.Schema
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
-import Database.Persist.Migration
+import Database.Persist.Sql (SqlBackend, toSqlKey)
+import Web.PathPieces (toPathPiece)
 
+import Vervis.Migration.Model
 import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Model.Workflow
 
 changes :: MonadIO m => [SchemaT SqlBackend m ()]
 changes =
-    [ addField "Workflow"
+    [ -- 1
+      traverse_ addEntity model_2016_08_04
+      -- 2
+    , unsetFieldDefault "Sharer" "created"
+      -- 3
+    , unsetFieldDefault "Project" "nextTicket"
+      -- 4
+    , unsetFieldDefault "Repo" "vcs"
+      -- 5
+    , unsetFieldDefault "Repo" "mainBranch"
+      -- 6
+    , removeField "Ticket" "done"
+      -- 7
+    , addField "Ticket" (Just "'TSNew'") $ Field
+        "status"
+        (FTPrim $ backendDataType (Proxy :: Proxy Text))
+        FieldRequired
+      -- 8
+    , traverse_ addEntity model_2016_09_01_just_workflow
+      -- 9
+    , traverse_ addEntity model_2016_09_01_rest
+      -- 10
+    , do
+        let key = fromBackendKey defaultBackendKey :: Key Workflow2016
+        noProjects <-
+            lift $ null <$> selectKeysList [] [LimitTo 1 :: SelectOpt Project]
+        unless noProjects $ lift $ do
+            msid <- listToMaybe <$> selectKeysList [] [Asc SharerId, LimitTo 1]
+            for_ msid $ \ sid -> do
+                let ident = text2wfl "dummy"
+                    w = Workflow2016 sid ident Nothing Nothing WSPublic
+                insertKey key w
+        addField "Project" (Just $ toPathPiece key) $ Field
+            "workflow"
+            (FTRef "Workflow")
+            FieldRequired
+      -- 11
+    , addField "Workflow"
         (Just "'WSSharer'")
         (Field
             "scope"
             (FTPrim $ backendDataType (Proxy :: Proxy Text))
             FieldRequired
         )
+      -- 12
     , changeFieldType "Person" "hash" $
         backendDataType (Proxy :: Proxy ByteString)
+      -- 13
     , unsetFieldMaybe "Person" "email" "'no@email'"
+      -- 14
     , addField "Person" (Just "TRUE") Field
         { fieldName  = "verified"
         , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Bool)
         , fieldMaybe = FieldRequired
         }
+      -- 15
     , addField "Person" (Just "''") Field
         { fieldName  = "verifiedKey"
         , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Text)
         , fieldMaybe = FieldRequired
         }
+      -- 16
     , addField "Person" (Just "''") Field
         { fieldName  = "resetPassphraseKey"
         , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Text)
         , fieldMaybe = FieldRequired
         }
+      -- 17
     , renameField "Person" "hash" "passphraseHash"
     ]
 

src/Vervis/Migration/Model.hs

@@ -0,0 +1,54 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Migration.Model
+    ( model_2016_08_04
+    , model_2016_09_01_just_workflow
+    , Workflow2016Generic (..)
+    , Workflow2016
+    , model_2016_09_01_rest
+    )
+where
+
+import Prelude
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Time (UTCTime)
+import Database.Persist.Schema (Entity)
+import Database.Persist.Schema.SQL ()
+import Database.Persist.Sql (SqlBackend)
+
+import Vervis.Migration.TH (schema)
+import Vervis.Model (SharerId)
+import Vervis.Model.Group
+import Vervis.Model.Ident
+import Vervis.Model.Repo
+import Vervis.Model.Role
+import Vervis.Model.TH (modelFile, makeEntitiesMigration)
+import Vervis.Model.Ticket
+import Vervis.Model.Workflow
+
+model_2016_08_04 :: [Entity SqlBackend]
+model_2016_08_04 = $(schema "2016_08_04")
+
+model_2016_09_01_just_workflow :: [Entity SqlBackend]
+model_2016_09_01_just_workflow = $(schema "2016_09_01_just_workflow")
+
+makeEntitiesMigration "2016"
+    $(modelFile "migrations/2016_09_01_just_workflow.model")
+
+model_2016_09_01_rest :: [Entity SqlBackend]
+model_2016_09_01_rest = $(schema "2016_09_01_rest")

src/Vervis/Migration/TH.hs

@@ -0,0 +1,29 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Migration.TH
+    ( schema
+    )
+where
+
+import Prelude
+
+import Database.Persist.Schema.TH (entitiesFromFile)
+import Language.Haskell.TH (Q, Exp)
+import System.FilePath ((</>), (<.>))
+
+-- | Makes expression of type [Database.Persist.Schema.Entity]
+schema :: String -> Q Exp
+schema s = entitiesFromFile $ "migrations" </> s <.> "model"

src/Vervis/Model.hs

@@ -33,13 +33,10 @@ import Vervis.Model.Ident
 import Vervis.Model.Repo
 import Vervis.Model.Role
 import Vervis.Model.Ticket
+import Vervis.Model.TH
 import Vervis.Model.Workflow
 
--- You can define all of your database entities in the entities file.
--- You can find more information on persistent and how to declare entities at:
--- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings{-, mkMigrate "migrateAll"-}]
-    $(persistFileWith lowerCaseSettings "config/models")
+makeEntities $(modelFile "config/models")
 
 instance PersistUserCredentials Person where
     userUsernameF       = PersonLogin

src/Vervis/Model/TH.hs

@@ -0,0 +1,146 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Model.TH
+    ( model
+    , modelFile
+    , makeEntities
+    , makeEntitiesGeneric
+    , makeEntitiesMigration
+    )
+where
+
+import Prelude
+
+import Control.Applicative ((<|>))
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Database.Persist.Quasi (lowerCaseSettings)
+import Database.Persist.TH
+import Database.Persist.Types
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Language.Haskell.TH.Syntax (Q, Exp, Dec)
+
+import Language.Haskell.TH.Quote.Local (decQuasiQuoter)
+
+model :: QuasiQuoter
+model = persistLowerCase
+
+modelFile :: FilePath -> Q Exp
+modelFile = persistFileWith lowerCaseSettings
+
+-- | Declare datatypes and 'PeristEntity' instances. Use the SQL backend. If
+-- Vervis moves to a different backend, or supports more backends, this
+-- function can be changed accordingly to make all the models use the new
+-- settings.
+makeEntities :: [EntityDef] -> Q [Dec]
+makeEntities = mkPersist sqlSettings
+
+-- | Like 'makeEntities', but declares generic datatypes not tied to a specific
+-- @persistent@ backend. It does also declare convenience type aliases for the
+-- SQL backend.
+makeEntitiesGeneric :: [EntityDef] -> Q [Dec]
+makeEntitiesGeneric = mkPersist sqlSettings { mpsGeneric = True }
+
+append :: [Text] -> Text -> EntityDef -> EntityDef
+append entnames suffix entity =
+    let upd = (<> suffix)
+
+        updId = (<> "Id") . upd
+
+        updateConEnt t =
+            if t `elem` entnames
+                then Just $ upd t
+                else Nothing
+
+        updateConId t =
+            updId <$> lookup t (zip (map (<> "Id") entnames) entnames)
+
+        updateCon t = fromMaybe t $ updateConEnt t <|> updateConId t
+
+        updateType t@(FTTypeCon (Just _) _) = t
+        updateType (FTTypeCon Nothing a) = FTTypeCon Nothing $ updateCon a
+        updateType (FTApp a b) = FTApp (updateType a) (updateType b)
+        updateType (FTList a) = FTList $ updateType a
+
+        updateEnt (HaskellName t) = HaskellName $ fromMaybe t $ updateConEnt t
+
+        updateEmbedField f = f
+            { emFieldEmbed = updateEmbedEnt <$> emFieldEmbed f
+            , emFieldCycle = updateEnt <$> emFieldCycle f
+            }
+
+        updateEmbedEnt e = EmbedEntityDef
+            { embeddedHaskell = updateEnt $ embeddedHaskell e
+            , embeddedFields  = map updateEmbedField $ embeddedFields e
+            }
+
+        updateComp c = c
+            { compositeFields = map updateField $ compositeFields c
+            }
+
+        updateRef NoReference = NoReference
+        updateRef (ForeignRef n t) = ForeignRef (updateEnt n) (updateType t)
+        updateRef (EmbedRef e) = EmbedRef $ updateEmbedEnt e
+        updateRef (CompositeRef c) = CompositeRef $ updateComp c
+        updateRef SelfReference = SelfReference
+
+        updateField f = f
+            { fieldType      = updateType $ fieldType f
+            , fieldReference = updateRef $ fieldReference f
+            }
+
+        updateName (HaskellName t) = HaskellName $ upd t
+
+        updateForeign f = f
+            { foreignRefTableHaskell = updateEnt $ foreignRefTableHaskell f
+            }
+
+    in  entity
+            { entityHaskell  = updateName $ entityHaskell entity
+            , entityId       = updateField $ entityId entity
+            , entityFields   = map updateField $ entityFields entity
+            , entityForeigns = map updateForeign $ entityForeigns entity
+            }
+
+-- | Like 'makeEntitiesGeneric', but appends the given suffix to the names of
+-- all entities, only on the Haskell side. It appends to the type constructor
+-- names and the data constructor names. Record field names (e.g. @personAge@)
+-- and 'EntityField' values (e.g. @PersonAge@) should be automatically adjusted
+-- based on that. Field types and references are updated too.
+--
+-- For example, the following model:
+--
+-- > Person
+-- >    name Text
+-- >    age  Int
+-- > Book
+-- >    author PersonId
+--
+-- Would have its Haskell datatypes looking more or less like this, given the
+-- suffix text is, say, \"2016\":
+--
+-- > data Person2016Generic backend = Person2016
+-- >    { person2016Name :: Text
+-- >    , person2016Age  :: Int
+-- >    }
+-- > data Book2016Generic backend = Book2016
+-- >    { book2016Author :: Person2016Id
+-- >    }
+makeEntitiesMigration :: Text -> [EntityDef] -> Q [Dec]
+makeEntitiesMigration suffix entities =
+    let names = map (unHaskellName . entityHaskell) entities
+    in  makeEntitiesGeneric $ map (append names suffix) entities

stack.yaml

@@ -31,6 +31,7 @@ extra-deps:
   - monad-hash-0.1
     # for 'tuple' package, remove once I use lenses instead
   - OneTuple-0.2.1
+  - persistent-parser-0.1.0.2
   - SimpleAES-0.4.2
     # for text drawing with 'diagrams'
   - SVGFonts-1.5.0.1

vervis.cabal

@@ -82,6 +82,7 @@ library
                        Database.Persist.Local.Sql.Orphan.PersistQueryForest
                        Diagrams.IntransitiveDAG
                        Formatting.CaseInsensitive
+                       Language.Haskell.TH.Quote.Local
                        Network.SSH.Local
                        Text.Blaze.Local
                        Text.Display
@@ -146,6 +147,8 @@ library
                        Vervis.Import.NoFoundation
                        Vervis.MediaType
                        Vervis.Migration
+                       Vervis.Migration.Model
+                       Vervis.Migration.TH
                        Vervis.Model
                        Vervis.Model.Entity
                        Vervis.Model.Group
@@ -153,6 +156,7 @@ library
                        Vervis.Model.Repo
                        Vervis.Model.Role
                        Vervis.Model.Ticket
+                       Vervis.Model.TH
                        Vervis.Model.Workflow
                        Vervis.Paginate
                        Vervis.Palette