diff --git a/src/Vervis/Persist.hs b/src/Vervis/Persist.hs index f9c1a5c..16251b6 100644 --- a/src/Vervis/Persist.hs +++ b/src/Vervis/Persist.hs @@ -29,6 +29,8 @@ module Vervis.Persist where import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Logger (runStderrLoggingT) import Data.Text (Text) import Data.Traversable (forM) import Database.Esqueleto ((^.), (&&.), (==.)) @@ -36,6 +38,7 @@ import Database.Persist hiding ((==.)) import Database.Persist.Sqlite hiding ((==.)) import Database.Persist.TH import Vervis.Git +import Yesod hiding ((==.)) import qualified Data.Text as T import qualified Database.Esqueleto as E @@ -88,62 +91,94 @@ PersonInGroup |] -mainViewQuery :: IO () -mainViewQuery = runSqlite ":memory:" $ do - runMigration migrateAll +data MainView = MainView ConnectionPool - --create some sharers - cindyId <- insert $ Sharer "cindy" Nothing - bobId <- insert $ Sharer "bob" Nothing - aliceId <- insert $ Sharer "alice" Nothing +mkYesod "MainView" [parseRoutes| +/ HomeR GET +|] - --create some projects - proj4Id <- insert $ Project "proj4" cindyId Nothing Nothing - proj2Id <- insert $ Project "proj2" aliceId Nothing Nothing - proj6Id <- insert $ Project "proj6" cindyId Nothing Nothing - proj3Id <- insert $ Project "proj3" bobId Nothing Nothing - proj5Id <- insert $ Project "proj5" cindyId Nothing Nothing - proj1Id <- insert $ Project "proj1" aliceId Nothing Nothing +instance Yesod MainView - --create some repos - insert_ $ Repo "repo8" proj5Id Nothing Nothing - insert_ $ Repo "repo1" proj1Id Nothing Nothing - insert_ $ Repo "repo6" proj4Id Nothing Nothing - insert_ $ Repo "repo3" proj3Id Nothing Nothing - insert_ $ Repo "repo4" proj3Id Nothing Nothing - insert_ $ Repo "repo10" proj6Id Nothing Nothing - insert_ $ Repo "repo5" proj4Id Nothing Nothing - insert_ $ Repo "repo7" proj5Id Nothing Nothing - insert_ $ Repo "repo2" proj2Id Nothing Nothing - insert_ $ Repo "repo9" proj5Id Nothing Nothing - insert_ $ Repo "repo11" proj6Id Nothing Nothing - insert_ $ Repo "repo12" proj6Id Nothing Nothing +instance YesodPersist MainView where + type YesodPersistBackend MainView = SqlBackend - repos <- E.select $ E.from $ \ (sharer, project, repo) -> do - E.where_ $ - project ^. ProjectSharer ==. sharer ^. SharerId &&. - repo ^. RepoProject ==. project ^. ProjectId - E.orderBy - [ E.asc $ sharer ^. SharerIdent - , E.asc $ project ^. ProjectIdent - , E.asc $ repo ^. RepoIdent - ] - return - ( sharer ^. SharerIdent - , project ^. ProjectIdent - , repo ^. RepoIdent - ) - rows <- liftIO $ forM repos $ \ (E.Value sharer, E.Value project, E.Value repo) -> do - let path = - T.unpack $ - T.intercalate "/" - [ "state2" - , sharer - , project - , repo - ] - dt <- lastChange path - ago <- timeAgo dt - return (sharer, project, repo, T.pack ago) + runDB action = do + MainView pool <- getYesod + runSqlPool action pool - liftIO $ mapM_ print rows +getHomeR :: Handler Html +getHomeR = do + rows <- runDB $ do + repos <- E.select $ E.from $ \ (sharer, project, repo) -> do + E.where_ $ + project ^. ProjectSharer ==. sharer ^. SharerId &&. + repo ^. RepoProject ==. project ^. ProjectId + E.orderBy + [ E.asc $ sharer ^. SharerIdent + , E.asc $ project ^. ProjectIdent + , E.asc $ repo ^. RepoIdent + ] + return + ( sharer ^. SharerIdent + , project ^. ProjectIdent + , repo ^. RepoIdent + ) + liftIO $ forM repos $ \ (E.Value sharer, E.Value project, E.Value repo) -> do + let path = + T.unpack $ + T.intercalate "/" + [ "state2" + , sharer + , project + , repo + ] + dt <- lastChange path + ago <- timeAgo dt + return (sharer, project, repo, T.pack ago) + + defaultLayout + [whamlet| +
#{sharer} + | #{proj} + | #{repo} + | #{ago} + |] + +openConnectionCount :: Int +openConnectionCount = 10 + +mainView :: IO () +mainView = + runStderrLoggingT $ + withSqlitePool "test.db3" openConnectionCount $ + \ pool -> liftIO $ do + runResourceT $ flip runSqlPool pool $ do + runMigration migrateAll + + cindyId <- insert $ Sharer "cindy" Nothing + bobId <- insert $ Sharer "bob" Nothing + aliceId <- insert $ Sharer "alice" Nothing + + proj4Id <- insert $ Project "proj4" cindyId Nothing Nothing + proj2Id <- insert $ Project "proj2" aliceId Nothing Nothing + proj6Id <- insert $ Project "proj6" cindyId Nothing Nothing + proj3Id <- insert $ Project "proj3" bobId Nothing Nothing + proj5Id <- insert $ Project "proj5" cindyId Nothing Nothing + proj1Id <- insert $ Project "proj1" aliceId Nothing Nothing + + insert_ $ Repo "repo8" proj5Id Nothing Nothing + insert_ $ Repo "repo1" proj1Id Nothing Nothing + insert_ $ Repo "repo6" proj4Id Nothing Nothing + insert_ $ Repo "repo3" proj3Id Nothing Nothing + insert_ $ Repo "repo4" proj3Id Nothing Nothing + insert_ $ Repo "repo10" proj6Id Nothing Nothing + insert_ $ Repo "repo5" proj4Id Nothing Nothing + insert_ $ Repo "repo7" proj5Id Nothing Nothing + insert_ $ Repo "repo2" proj2Id Nothing Nothing + insert_ $ Repo "repo9" proj5Id Nothing Nothing + insert_ $ Repo "repo11" proj6Id Nothing Nothing + insert_ $ Repo "repo12" proj6Id Nothing Nothing + warp 3000 $ MainView pool diff --git a/vervis.cabal b/vervis.cabal index 509f3e0..fba7a68 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -44,13 +44,17 @@ library , json-state , hashable , hourglass + , monad-logger , persistent , persistent-sqlite , persistent-template + , resourcet , text >=1 , time-units , transformers >=0.4.2 , unordered-containers >=0.2.5 + , yesod + , yesod-persistent hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall |