Add OAuth2 tables to database, and run their migrations

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
+        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
     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.

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

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

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

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

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

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
+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

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

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

vervis.cabal

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