debugged history viewer

Foundation.hs

@@ -56,6 +56,8 @@ instance PathPiece BS.ByteString where
   toPathPiece bs = T.decodeUtf8 bs
   fromPathPiece t = Just $ T.encodeUtf8 t
 
+type Strings = [String]
+
 data ObjPiece = ObjPiece String [FilePath]
                 deriving (Show, Eq, Ord, Read)
 

GitUtils.hs

@@ -122,6 +122,16 @@ fromBlob (GoBlob _ bs) = (flip decode bs =<< detectEncoding bs)
                      <|> either (const Nothing) Just (T.unpack <$> T.decodeUtf8' bs)
 fromBlob _             = Nothing
 
+traverseGoTree :: Gitolite -> Repository
+               -> [FilePath] -> GitObject -> IO GitObject
+traverseGoTree _ _ []     obj           = return obj
+traverseGoTree g r (p:ps) (GoTree _ es) = do
+  entry <- maybe (throwIO GitEntryNotExist) return $ find ((==p).fileName) es
+  traverseGoTree g r ps =<< sha1ToObj (fileRef entry) (repoDir g r)
+traverseGoTree _ _ _      _             = throwIO GitEntryNotExist
+
+repoBranch :: Gitolite -> Repository -> String -> IO Branch
+repoBranch git repo name = gitBranch name (repoDir git repo)
 
 repoBranches :: Gitolite -> Repository -> IO [Branch]
 repoBranches git repo = do

Handler/Repos.hs

@@ -30,6 +30,7 @@ import Data.Function
 import Control.Arrow
 import Data.Time
 import System.Locale
+import System.Directory
 
 getTreeR :: String -> ObjPiece -> Handler RepHtml
 getTreeR repon op@(ObjPiece com xs) = withRepoObj repon op $ \git repo obj -> do
@@ -114,15 +115,30 @@ getTagsR repon = withRepo repon $ \git repo -> do
   repoLayout repon (ObjPiece "master" []) $ do
     $(widgetFile "tags")
 
-getCommitsR :: String -> ObjPiece -> Handler RepHtml
-getCommitsR repon op@(ObjPiece br _) = withRepoObj repon op $ \git repo obj -> do
+getCommitsR :: String -> [String] -> Handler RepHtml
+getCommitsR repon [] = withRepo repon $ \git repo -> do
   brs <- liftIO $ repoBranches git repo
   commits <- liftIO (concat <$> mapM (repoCommitsForBranch git repo) brs)
   let commitGroups = map (pprTime . commitDate . head &&& id) $
                        groupBy ((==) `on` utctDay . commitDate) commits
+  let op = ObjPiece "master" []
   repoLayout repon op $ do
     $(widgetFile "commits")
 
+getCommitsR repon (c:ps) = withRepo repon $ \git repo -> do
+  let (prfx, rest) = splitAt 2 c
+  isCommit <- liftIO $ doesFileExist (repoDir git repo </> "objects" </> prfx </> rest)
+  if isCommit
+    then redirect $ CommitsR repon []
+    else do
+      obj <- liftIO $ gitPathToObj "/" (repoDir git repo)
+      commits <- liftIO (repoCommitsForBranch git repo =<< gitBranch c (repoDir git repo))
+      let commitGroups = map (pprTime . commitDate . head &&& id) $
+                           groupBy ((==) `on` utctDay . commitDate) commits
+      let op = ObjPiece c ps
+      repoLayout repon op $ do
+        $(widgetFile "commits")
+
 pprTime :: UTCTime -> String
 pprTime = formatTime defaultTimeLocale "%F"
 

Import.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module Import
     ( module Prelude
     , module Foundation
@@ -43,6 +44,9 @@ import Database.Persist.Store
 import qualified Data.Text as T
 import Encodings
 import ContentTypes
+import Control.Exception (try, SomeException(..))
+import System.FilePath
+import System.Directory
 
 isBlob, isTree :: Git.GitObject -> Bool
 isBlob (Git.GoBlob _ _) = True
@@ -64,8 +68,17 @@ withRepoObj :: String
             -> Handler a
 withRepoObj repon (ObjPiece commit path) act = do
   withRepo repon $ \git repo -> do
-    let curPath = intercalate "/" $ commit:path
-    obj <- liftIO $ Git.gitPathToObj curPath (repoDir git repo)
+    let gitDir         = repoDir git repo
+        (prefix, rest) = splitAt 2 commit
+
+    root <- liftIO $ do
+      isHash <- doesFileExist $ gitDir </> "objects" </> prefix </> rest
+      if isHash
+        then Git.sha1ToObj (Git.SHA1 commit) gitDir
+        else repoBranch git repo commit >>= flip Git.sha1ToObj gitDir . commitRef . branchHEAD
+    let curPath = intercalate "/" (commit:path)
+    liftIO $ print root
+    obj <- liftIO $ traverseGoTree git repo path root
     setSessionBS "curPath" (BS.pack curPath)
     ans <- act git repo obj
     deleteSession "curPath"

config/routes

@@ -7,8 +7,7 @@
 /repo/#String/blob/*ObjPiece BlobR GET
 /repo/#String/raw/*ObjPiece RawBlobR GET
 /repo/#String/tags                 TagsR GET
-/repo/#String/branches     BranchesR GET
-/repo/#String/commits/*ObjPiece     CommitsR GET
+/repo/#String/commits/*Strings     CommitsR GET
 /repo/#String/commit/#BS.ByteString       CommitR GET
 /repo/#String/compress/*ObjPiece   CompressR GET
 / RootR GET

gitolist.cabal

@@ -54,6 +54,7 @@ library
                 OverloadedStrings
                 MultiParamTypeClasses
                 TypeFamilies
+                TypeSynonymInstances
                 GADTs
                 GeneralizedNewtypeDeriving
                 FlexibleContexts
@@ -84,6 +85,7 @@ executable         gitolist
                 OverloadedStrings
                 MultiParamTypeClasses
                 TypeFamilies
+                TypeSynonymInstances
                 GADTs
                 GeneralizedNewtypeDeriving
                 FlexibleContexts
@@ -147,6 +149,7 @@ executable register-user
                 OverloadedStrings
                 MultiParamTypeClasses
                 TypeFamilies
+                TypeSynonymInstances
                 GADTs
                 GeneralizedNewtypeDeriving
                 FlexibleContexts

templates/repo-layout.hamlet

@@ -50,7 +50,7 @@
       <a href=@{TagsR repon}>
         Tags
     <li #tab_commits>
-      <a href=@{CommitsR repon (mkObjPiece commit)}>
+      <a href=@{CommitsR repon (pure commit)}>
         Commits
   $if not (curTab == "tab_tags")
     <h3>