Make minimal Yesod app that returns main view as an HTML table

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 ()
+data MainView = MainView ConnectionPool
-mainViewQuery = runSqlite ":memory:" $ do
-    runMigration migrateAll
 
-    --create some sharers
+mkYesod "MainView" [parseRoutes|
-    cindyId <- insert $ Sharer "cindy" Nothing
+/ HomeR GET
-    bobId <- insert $ Sharer "bob" Nothing
+|]
-    aliceId <- insert $ Sharer "alice" Nothing
 
-    --create some projects
+instance Yesod MainView
-    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
 
-    --create some repos
+instance YesodPersist MainView where
-    insert_ $ Repo "repo8" proj5Id Nothing Nothing
+    type YesodPersistBackend MainView = SqlBackend
-    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
 
-    repos <- E.select $ E.from $ \ (sharer, project, repo) -> do
+    runDB action = do
-        E.where_ $
+        MainView pool <- getYesod
-            project ^. ProjectSharer ==. sharer ^. SharerId &&.
+        runSqlPool action pool
-            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)
 
-    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|
+            <table>
+                $forall (sharer, proj, repo, ago) <- rows
+                    <tr>
+                        <td>#{sharer}
+                        <td>#{proj}
+                        <td>#{repo}
+                        <td>#{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

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