Make minimal Yesod app that returns main view as an HTML table
This commit is contained in:
fr33domlover
parent
73acda0ecf
commit
1abfc11ffa
2 changed files with 93 additions and 54 deletions
|
|
@ -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|
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue