mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-28 07:14:50 +09:00
Add OAuth2 tables to database, and run their migrations
This commit is contained in:
parent
da4b818761
commit
ac477ab739
10 changed files with 59 additions and 132 deletions
|
@ -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.
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue