diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 8b61716..a93268d 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -41,7 +41,9 @@ import Data.Foldable import Data.Git.Repository (isRepo) import Data.List.NonEmpty (nonEmpty) import Data.Maybe +import Data.Proxy import Data.String +import Data.Text (Text) import Data.Traversable import Database.Persist.Postgresql import Graphics.SVGFonts.Fonts (lin2) @@ -70,10 +72,11 @@ import Yesod.Persist.Core import Yesod.Static import qualified Data.CaseInsensitive as CI -import qualified Data.Text as T (unpack) +import qualified Data.Text as T import qualified Database.Esqueleto as E import Database.Persist.Schema.PostgreSQL (schemaBackend) +import Dvara import Yesod.Mail.Send (runMailer) import Control.Concurrent.ResultShare @@ -205,19 +208,13 @@ makeFoundation appSettings = do --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc let hLocal = appInstanceHost appSettings flip runWorker app $ runSiteDB $ do - r <- migrateDB hLocal hashidsCtx - case r of - Left err -> do - let msg = "DB migration failed: " <> err - $logError msg - error $ T.unpack msg - Right (_from, _to) -> do - $logInfo "DB migration success" - verifyRepoDir - fixRunningDeliveries - deleteUnusedURAs - writePostReceiveHooks - writePostApplyHooks + migrate "Vervis" $ migrateDB hLocal hashidsCtx + migrate "Dvara" $ migrateDvara (Proxy :: Proxy App) schemaBackend + verifyRepoDir + fixRunningDeliveries + deleteUnusedURAs + writePostReceiveHooks + writePostApplyHooks let hostString = T.unpack $ renderAuthority hLocal writeHookConfig hostString Config @@ -286,6 +283,19 @@ makeFoundation appSettings = do (first (lower . unRpIdent) . bimap E.unValue E.unValue . snd) where lower = T.unpack . CI.foldedCase + migrate :: MonadLogger m => Text -> ReaderT b m (Either Text (Int, Int)) -> ReaderT b m () + migrate name a = do + r <- a + case r of + Left err -> do + let msg = "DB migration failed: " <> name <> ": " <> err + $logError msg + error $ T.unpack msg + Right (from, to) -> + $logInfo $ T.concat + [ "DB migration success: ", name, ": " + , T.pack $ show from, " ==> ", T.pack $ show to + ] -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index b91e49e..be62800 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -35,6 +35,7 @@ import Network.HTTP.Types.Header import Text.Shakespeare.Text (textFile) import Text.Hamlet (hamletFile) --import Text.Jasmine (minifym) +import Text.Read import Web.Hashids import Yesod.Auth import Yesod.Auth.Account @@ -57,6 +58,7 @@ import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.Text as T --import qualified Data.Text.Encoding as TE +import Dvara import Network.HTTP.Digest import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders) import Yesod.Auth.Unverified @@ -677,6 +679,21 @@ instance YesodAuthAccount AccountPersistDB' App where else Just $ setMessage "Maximal number of registered users reached" else return $ Just $ setMessage "User registration disabled" +instance YesodAuthDvara App where + data YesodAuthDvaraScope App = ScopeRead deriving Eq + renderAuthId _ pid = T.pack $ show $ fromSqlKey pid + parseAuthId _ t = + maybe (Left err) (Right . toSqlKey) $ readMaybe $ T.unpack t + where + err = "Failed to parse an Int64 for AuthId a.k.a PersonId" + +instance DvaraScope (YesodAuthDvaraScope App) where + renderScope ScopeRead = "read" + parseScope "read" = Right ScopeRead + parseScope _ = Left "Unrecognized scope" + defaultScopes = pure ScopeRead + selfScopes = pure ScopeRead + -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage App FormMessage where diff --git a/src/Vervis/KeyFile.hs b/src/Vervis/KeyFile.hs index f4b5b6b..56fa673 100644 --- a/src/Vervis/KeyFile.hs +++ b/src/Vervis/KeyFile.hs @@ -53,4 +53,4 @@ import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool) -- Otherwise, we'll only use existing keys loaded from files. isInitialSetup :: ConnectionPool -> SchemaBackend SqlBackend -> IO Bool isInitialSetup pool sb = - flip runSqlPool pool . flip runReaderT sb $ not <$> hasEntities + flip runSqlPool pool . flip runReaderT (sb, "") $ not <$> hasEntities diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 84f71c2..5933894 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -115,7 +115,7 @@ changes hLocal ctx = -- 9 , addEntities model_2016_09_01_rest -- 10 - , let key = fromBackendKey defaultBackendKey :: Key Workflow2016 + , let key = toSqlKey 1 :: Key Workflow2016 in withPrepare (addFieldRefRequired "Project" (toBackendKey key) @@ -1515,5 +1515,5 @@ migrateDB :: (MonadSite m, SiteEnv m ~ App) => Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB hLocal ctx = - let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs + let f cs = fmap (, length cs) <$> runMigrations schemaBackend "" 1 cs in f $ changes hLocal ctx diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 33d755c..0662091 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -190,6 +190,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.SQL () +import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Vervis.FedURI @@ -199,7 +200,7 @@ 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.TH import Vervis.Model.Workflow -- For migrations 77, 114 diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index cc84086..0148e2f 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -26,6 +26,8 @@ import Data.Time.Clock import Database.Persist.Quasi import Database.Persist.Sql (fromSqlKey) import Text.Email.Validate (EmailAddress) + +import Database.Persist.Schema.TH hiding (modelFile) import Yesod.Auth.Account (PersistUserCredentials (..)) import Crypto.PublicVerifKey diff --git a/src/Vervis/Model/TH.hs b/src/Vervis/Model/TH.hs index 5866c2b..3ca06e9 100644 --- a/src/Vervis/Model/TH.hs +++ b/src/Vervis/Model/TH.hs @@ -16,9 +16,6 @@ module Vervis.Model.TH ( model , modelFile - , makeEntities - , makeEntitiesGeneric - , makeEntitiesMigration ) where @@ -32,118 +29,15 @@ import Database.Persist.Types import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp, Dec) +import qualified Database.Persist.Schema.TH as PS + import Language.Haskell.TH.Quote.Local (decQuasiQuoter) +component :: Text +component = "" + model :: QuasiQuoter -model = persistLowerCase +model = PS.model component 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 - } - - updateUnique u = u - { uniqueHaskell = updateName $ uniqueHaskell u - } - - in entity - { entityHaskell = updateName $ entityHaskell entity - , entityId = updateField $ entityId entity - , entityFields = map updateField $ entityFields entity - , entityUniques = map updateUnique $ entityUniques 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 +modelFile = PS.modelFile component diff --git a/stack.yaml b/stack.yaml index 56278aa..f5fa000 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,6 +16,7 @@ extra-deps: commit: 2d19eea0fae58897a02372a84cc48e7696a4e288 - ./lib/darcs-lights - ./lib/darcs-rev + - ./lib/dvara - ./lib/ssh - ./lib/hit-graph - ./lib/hit-harder diff --git a/update-deps.sh b/update-deps.sh index e4a138b..9f9e266 100644 --- a/update-deps.sh +++ b/update-deps.sh @@ -2,7 +2,8 @@ VERVIS='https://dev.angeley.es/s/fr33domlover/r' -DEPS='hit-graph +DEPS='dvara + hit-graph hit-harder hit-network darcs-lights diff --git a/vervis.cabal b/vervis.cabal index d67334d..9251673 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -277,6 +277,7 @@ library -- for Data.Git.Local , directory-tree , dlist + , dvara , email-validate , email-validate-json , esqueleto