diff --git a/migrations/2016_08_04.model b/migrations/2016_08_04.model new file mode 100644 index 0000000..f48cf19 --- /dev/null +++ b/migrations/2016_08_04.model @@ -0,0 +1,196 @@ +-- This file is part of Vervis. +-- +-- Written in 2016 by fr33domlover . +-- +-- ♡ 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 +-- . + +------------------------------------------------------------------------------- +-- 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 diff --git a/migrations/2016_09_01_just_workflow.model b/migrations/2016_09_01_just_workflow.model new file mode 100644 index 0000000..cb2b4c5 --- /dev/null +++ b/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 diff --git a/migrations/2016_09_01_rest.model b/migrations/2016_09_01_rest.model new file mode 100644 index 0000000..c86158e --- /dev/null +++ b/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 diff --git a/src/Language/Haskell/TH/Quote/Local.hs b/src/Language/Haskell/TH/Quote/Local.hs new file mode 100644 index 0000000..8816c33 --- /dev/null +++ b/src/Language/Haskell/TH/Quote/Local.hs @@ -0,0 +1,45 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ 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 + - . + -} + +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" diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 3b8e07a..2aca508 100644 --- a/src/Vervis/Migration.hs +++ b/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" ] diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs new file mode 100644 index 0000000..c899bb8 --- /dev/null +++ b/src/Vervis/Migration/Model.hs @@ -0,0 +1,54 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ 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 + - . + -} + +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") diff --git a/src/Vervis/Migration/TH.hs b/src/Vervis/Migration/TH.hs new file mode 100644 index 0000000..bf6f6d1 --- /dev/null +++ b/src/Vervis/Migration/TH.hs @@ -0,0 +1,29 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ 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 + - . + -} + +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" diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 467cb16..913ce50 100644 --- a/src/Vervis/Model.hs +++ b/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 diff --git a/src/Vervis/Model/TH.hs b/src/Vervis/Model/TH.hs new file mode 100644 index 0000000..6ad7f06 --- /dev/null +++ b/src/Vervis/Model/TH.hs @@ -0,0 +1,146 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/stack.yaml b/stack.yaml index 04b4812..4479608 100644 --- a/stack.yaml +++ b/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 diff --git a/vervis.cabal b/vervis.cabal index af99b08..de41a54 100644 --- a/vervis.cabal +++ b/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