Refactor git log view, make room for darcs

config/routes

@@ -44,7 +44,8 @@
 /u/#Text/r/!new                         RepoNewR          GET
 /u/#Text/r/#Text                        RepoR             GET
 /u/#Text/r/#Text/s/+Texts               RepoSourceR       GET
-/u/#Text/r/#Text/c                      RepoCommitsR      GET
+/u/#Text/r/#Text/c                      RepoHeadChangesR  GET
+/u/#Text/r/#Text/c/#Text                RepoChangesR      GET
 
 /u/#Text/r/#Text/git/info/refs          GitRefDiscoverR   GET
 --/u/#Text/r/#Text/git/git-upload-pack    GitUploadRequestR POST

src/Vervis/Foundation.hs

@@ -62,6 +62,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
 -- | A convenient synonym for creating forms.
 type Form a = Html -> MForm (HandlerT App IO) (FormResult a, Widget)
 
+type AppDB = YesodDB App
+
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod App where
@@ -273,7 +275,10 @@ instance YesodBreadcrumbs App where
                                               RepoSourceR shar repo $
                                               init refdir
                                             )
-        RepoCommitsR shar repo           -> ("History", Just $ RepoR shar repo)
+        RepoHeadChangesR shar repo       -> ("Changes", Just $ RepoR shar repo)
+        RepoChangesR shar repo ref       -> ( ref
+                                            , Just $ RepoHeadChangesR shar repo
+                                            )
 
         ProjectsR shar                   -> ("Projects", Just $ PersonR shar)
         ProjectNewR shar                 -> ("New", Just $ ProjectsR shar)

src/Vervis/Handler/Repo.hs

@@ -19,7 +19,8 @@ module Vervis.Handler.Repo
     , getRepoNewR
     , getRepoR
     , getRepoSourceR
-    , getRepoCommitsR
+    , getRepoHeadChangesR
+    , getRepoChangesR
     )
 where
 
@@ -133,23 +134,24 @@ instance ResultList D.DList where
     emptyList = D.empty
     appendItem = flip D.snoc
 
+selectRepo :: Text -> Text -> AppDB Repo
+selectRepo shar repo = do
+    Entity sid _s <- getBy404 $ UniqueSharerIdent shar
+    Entity _rid r <- getBy404 $ UniqueRepo repo sid
+    return r
+
 getRepoR :: Text -> Text -> Handler Html
-getRepoR user repo = do
+getRepoR shar repo = do
-    repository <- runDB $ do
+    repository <- runDB $ selectRepo shar repo
-        Entity sid _s <- getBy404 $ UniqueSharerIdent user
-        Entity _rid r <- getBy404 $ UniqueRepo repo sid
-        return r
     case repoVcs repository of
-        VCSDarcs -> getDarcsRepoSource repository user repo []
+        VCSDarcs -> getDarcsRepoSource repository shar repo []
         VCSGit ->
             getGitRepoSource
-                repository user repo (repoMainBranch repository) []
+                repository shar repo (repoMainBranch repository) []
 
 getDarcsRepoSource :: Repo -> Text -> Text -> [Text] -> Handler Html
 getDarcsRepoSource repository user repo dir = do
     path <- askRepoDir user repo
-    --let toText = decodeUtf8With lenientDecode
-    --    toTextL = L.decodeUtf8With lenientDecode
     msv <- liftIO $ D.readSourceView path dir
     case msv of
         Nothing -> notFound
@@ -157,15 +159,13 @@ getDarcsRepoSource repository user repo dir = do
             let parent = if null dir then [] else init dir
                 dirs = zip parent (tail $ inits parent)
             defaultLayout $ do
-                setTitle $ toHtml $ intercalate " > " $
+                setTitle $ toHtml $ intercalate " > "
                     ["Vervis", "People", user, "Repos", repo]
                 $(widgetFile "repo/source-darcs")
 
 getGitRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
 getGitRepoSource repository user repo ref dir = do
     path <- askRepoDir user repo
-    --let toText = decodeUtf8With lenientDecode
-    --    toTextL = L.decodeUtf8With lenientDecode
     (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
     case msv of
         Nothing -> notFound
@@ -178,26 +178,36 @@ getGitRepoSource repository user repo ref dir = do
                 $(widgetFile "repo/source-git")
 
 getRepoSourceR :: Text -> Text -> [Text] -> Handler Html
-getRepoSourceR user repo refdir = do
+getRepoSourceR shar repo refdir = do
-    repository <- runDB $ do
+    repository <- runDB $ selectRepo shar repo
-        Entity sid _s <- getBy404 $ UniqueSharerIdent user
-        Entity _rid r <- getBy404 $ UniqueRepo repo sid
-        return r
     case repoVcs repository of
-        VCSDarcs -> getDarcsRepoSource repository user repo refdir
+        VCSDarcs -> getDarcsRepoSource repository shar repo refdir
         VCSGit -> case refdir of
             []           -> notFound
-            (ref:dir) -> getGitRepoSource repository user repo ref dir
+            (ref:dir) -> getGitRepoSource repository shar repo ref dir
 
-getRepoCommitsR :: Text -> Text -> Handler Html
+getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
-getRepoCommitsR user repo = do
+getDarcsRepoHeadChanges shar repo = notFound
-    repository <- runDB $ do
+
-        Entity sid _s <- getBy404 $ UniqueSharerIdent user
+getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html
-        Entity _rid r <- getBy404 $ UniqueRepo repo sid
+getGitRepoHeadChanges repository shar repo =
-        return r
+    getGitRepoChanges shar repo $ repoMainBranch repository
-    path <- askRepoDir user repo
+
+getRepoHeadChangesR :: Text -> Text -> Handler Html
+getRepoHeadChangesR user repo = do
+    repository <- runDB $ selectRepo user repo
+    case repoVcs repository of
+        VCSDarcs -> getDarcsRepoHeadChanges user repo
+        VCSGit -> getGitRepoHeadChanges repository user repo
+
+getDarcsRepoChanges :: Text -> Text -> Text -> Handler Html
+getDarcsRepoChanges shar repo tag = notFound
+
+getGitRepoChanges :: Text -> Text -> Text -> Handler Html
+getGitRepoChanges shar repo ref = do
+    path <- askRepoDir shar repo
     pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
-        oid <- resolveName git $ unpack $ repoMainBranch repository
+        oid <- resolveName git $ unpack ref
         graph <- loadCommitGraphPT git [oid]
         let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
             nodes = case mnodes of
@@ -215,5 +225,12 @@ getRepoCommitsR user repo = do
         rows = map (uncurry mkrow) pairs
     defaultLayout $ do
         setTitle $ toHtml $ intercalate " > "
-            ["Vervis", "People", user, "Repos", repo, "Commits"]
+            ["Vervis", "People", shar, "Repos", repo, "Commits"]
-        $(widgetFile "repo/commits")
+        $(widgetFile "repo/changes-git")
+
+getRepoChangesR :: Text -> Text -> Text -> Handler Html
+getRepoChangesR shar repo ref = do
+    repository <- runDB $ selectRepo shar repo
+    case repoVcs repository of
+        VCSDarcs -> getDarcsRepoChanges shar repo ref
+        VCSGit -> getGitRepoChanges shar repo ref

templates/repo/source-darcs.hamlet

@@ -16,7 +16,7 @@ $maybe desc <- repoDesc repository
   <p>#{desc}
 
 <p>
-  <a href=@{RepoCommitsR user repo}>Commits
+  <a href=@{RepoHeadChangesR user repo}>Changes
 
 <h2>Branches
 

templates/repo/source-git.hamlet

@@ -16,7 +16,7 @@ $maybe desc <- repoDesc repository
   <p>#{desc}
 
 <p>
-  <a href=@{RepoCommitsR user repo}>Commits
+  <a href=@{RepoHeadChangesR user repo}>Commits
 
 <h2>Branches