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.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,14 +208,8 @@ 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"
|
||||
migrate "Vervis" $ migrateDB hLocal hashidsCtx
|
||||
migrate "Dvara" $ migrateDvara (Proxy :: Proxy App) schemaBackend
|
||||
verifyRepoDir
|
||||
fixRunningDeliveries
|
||||
deleteUnusedURAs
|
||||
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -16,6 +16,7 @@ extra-deps:
|
|||
commit: 2d19eea0fae58897a02372a84cc48e7696a4e288
|
||||
- ./lib/darcs-lights
|
||||
- ./lib/darcs-rev
|
||||
- ./lib/dvara
|
||||
- ./lib/ssh
|
||||
- ./lib/hit-graph
|
||||
- ./lib/hit-harder
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -277,6 +277,7 @@ library
|
|||
-- for Data.Git.Local
|
||||
, directory-tree
|
||||
, dlist
|
||||
, dvara
|
||||
, email-validate
|
||||
, email-validate-json
|
||||
, esqueleto
|
||||
|
|
Loading…
Reference in a new issue