Add OAuth2 tables to database, and run their migrations

This commit is contained in:
fr33domlover 2020-03-28 14:18:00 +00:00
parent da4b818761
commit ac477ab739
10 changed files with 59 additions and 132 deletions

View file

@ -41,7 +41,9 @@ import Data.Foldable
import Data.Git.Repository (isRepo) import Data.Git.Repository (isRepo)
import Data.List.NonEmpty (nonEmpty) import Data.List.NonEmpty (nonEmpty)
import Data.Maybe import Data.Maybe
import Data.Proxy
import Data.String import Data.String
import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Persist.Postgresql import Database.Persist.Postgresql
import Graphics.SVGFonts.Fonts (lin2) import Graphics.SVGFonts.Fonts (lin2)
@ -70,10 +72,11 @@ import Yesod.Persist.Core
import Yesod.Static import Yesod.Static
import qualified Data.CaseInsensitive as CI 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 qualified Database.Esqueleto as E
import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Dvara
import Yesod.Mail.Send (runMailer) import Yesod.Mail.Send (runMailer)
import Control.Concurrent.ResultShare import Control.Concurrent.ResultShare
@ -205,19 +208,13 @@ makeFoundation appSettings = do
--runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
let hLocal = appInstanceHost appSettings let hLocal = appInstanceHost appSettings
flip runWorker app $ runSiteDB $ do flip runWorker app $ runSiteDB $ do
r <- migrateDB hLocal hashidsCtx migrate "Vervis" $ migrateDB hLocal hashidsCtx
case r of migrate "Dvara" $ migrateDvara (Proxy :: Proxy App) schemaBackend
Left err -> do verifyRepoDir
let msg = "DB migration failed: " <> err fixRunningDeliveries
$logError msg deleteUnusedURAs
error $ T.unpack msg writePostReceiveHooks
Right (_from, _to) -> do writePostApplyHooks
$logInfo "DB migration success"
verifyRepoDir
fixRunningDeliveries
deleteUnusedURAs
writePostReceiveHooks
writePostApplyHooks
let hostString = T.unpack $ renderAuthority hLocal let hostString = T.unpack $ renderAuthority hLocal
writeHookConfig hostString Config writeHookConfig hostString Config
@ -286,6 +283,19 @@ makeFoundation appSettings = do
(first (lower . unRpIdent) . bimap E.unValue E.unValue . snd) (first (lower . unRpIdent) . bimap E.unValue E.unValue . snd)
where where
lower = T.unpack . CI.foldedCase 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 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares. -- applying some additional middlewares.

View file

@ -35,6 +35,7 @@ import Network.HTTP.Types.Header
import Text.Shakespeare.Text (textFile) import Text.Shakespeare.Text (textFile)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym) --import Text.Jasmine (minifym)
import Text.Read
import Web.Hashids import Web.Hashids
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.Account 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 as T
--import qualified Data.Text.Encoding as TE --import qualified Data.Text.Encoding as TE
import Dvara
import Network.HTTP.Digest import Network.HTTP.Digest
import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders) import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders)
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
@ -677,6 +679,21 @@ instance YesodAuthAccount AccountPersistDB' App where
else Just $ setMessage "Maximal number of registered users reached" else Just $ setMessage "Maximal number of registered users reached"
else return $ Just $ setMessage "User registration disabled" 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 -- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages. -- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where instance RenderMessage App FormMessage where

View file

@ -53,4 +53,4 @@ import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
-- Otherwise, we'll only use existing keys loaded from files. -- Otherwise, we'll only use existing keys loaded from files.
isInitialSetup :: ConnectionPool -> SchemaBackend SqlBackend -> IO Bool isInitialSetup :: ConnectionPool -> SchemaBackend SqlBackend -> IO Bool
isInitialSetup pool sb = isInitialSetup pool sb =
flip runSqlPool pool . flip runReaderT sb $ not <$> hasEntities flip runSqlPool pool . flip runReaderT (sb, "") $ not <$> hasEntities

View file

@ -115,7 +115,7 @@ changes hLocal ctx =
-- 9 -- 9
, addEntities model_2016_09_01_rest , addEntities model_2016_09_01_rest
-- 10 -- 10
, let key = fromBackendKey defaultBackendKey :: Key Workflow2016 , let key = toSqlKey 1 :: Key Workflow2016
in withPrepare in withPrepare
(addFieldRefRequired "Project" (addFieldRefRequired "Project"
(toBackendKey key) (toBackendKey key)
@ -1515,5 +1515,5 @@ migrateDB
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) => Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB hLocal ctx = 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 in f $ changes hLocal ctx

View file

@ -190,6 +190,7 @@ import Data.Time (UTCTime)
import Database.Persist.Class (EntityField, Unique) import Database.Persist.Class (EntityField, Unique)
import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL () import Database.Persist.Schema.SQL ()
import Database.Persist.Schema.TH (makeEntitiesMigration)
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
import Vervis.FedURI import Vervis.FedURI
@ -199,7 +200,7 @@ import Vervis.Model.Group
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Model.Role import Vervis.Model.Role
import Vervis.Model.TH (modelFile, makeEntitiesMigration) import Vervis.Model.TH
import Vervis.Model.Workflow import Vervis.Model.Workflow
-- For migrations 77, 114 -- For migrations 77, 114

View file

@ -26,6 +26,8 @@ import Data.Time.Clock
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist.Sql (fromSqlKey) import Database.Persist.Sql (fromSqlKey)
import Text.Email.Validate (EmailAddress) import Text.Email.Validate (EmailAddress)
import Database.Persist.Schema.TH hiding (modelFile)
import Yesod.Auth.Account (PersistUserCredentials (..)) import Yesod.Auth.Account (PersistUserCredentials (..))
import Crypto.PublicVerifKey import Crypto.PublicVerifKey

View file

@ -16,9 +16,6 @@
module Vervis.Model.TH module Vervis.Model.TH
( model ( model
, modelFile , modelFile
, makeEntities
, makeEntitiesGeneric
, makeEntitiesMigration
) )
where where
@ -32,118 +29,15 @@ import Database.Persist.Types
import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp, Dec) import Language.Haskell.TH.Syntax (Q, Exp, Dec)
import qualified Database.Persist.Schema.TH as PS
import Language.Haskell.TH.Quote.Local (decQuasiQuoter) import Language.Haskell.TH.Quote.Local (decQuasiQuoter)
component :: Text
component = ""
model :: QuasiQuoter model :: QuasiQuoter
model = persistLowerCase model = PS.model component
modelFile :: FilePath -> Q Exp modelFile :: FilePath -> Q Exp
modelFile = persistFileWith lowerCaseSettings modelFile = PS.modelFile component
-- | 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

View file

@ -16,6 +16,7 @@ extra-deps:
commit: 2d19eea0fae58897a02372a84cc48e7696a4e288 commit: 2d19eea0fae58897a02372a84cc48e7696a4e288
- ./lib/darcs-lights - ./lib/darcs-lights
- ./lib/darcs-rev - ./lib/darcs-rev
- ./lib/dvara
- ./lib/ssh - ./lib/ssh
- ./lib/hit-graph - ./lib/hit-graph
- ./lib/hit-harder - ./lib/hit-harder

View file

@ -2,7 +2,8 @@
VERVIS='https://dev.angeley.es/s/fr33domlover/r' VERVIS='https://dev.angeley.es/s/fr33domlover/r'
DEPS='hit-graph DEPS='dvara
hit-graph
hit-harder hit-harder
hit-network hit-network
darcs-lights darcs-lights

View file

@ -277,6 +277,7 @@ library
-- for Data.Git.Local -- for Data.Git.Local
, directory-tree , directory-tree
, dlist , dlist
, dvara
, email-validate , email-validate
, email-validate-json , email-validate-json
, esqueleto , esqueleto