From 3ed04941e8ff1878a44db7292f08240a56042052 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 5 May 2016 07:29:19 +0000 Subject: [PATCH] Refactor git source view code and implement the same for Darcs --- config/routes | 2 +- src/Darcs/Local.hs | 61 +++- src/Vervis/Darcs.hs | 103 ++++++ src/Vervis/Foundation.hs | 8 +- src/Vervis/Git.hs | 176 +++++------ src/Vervis/GitOld.hs | 124 ++++++++ src/Vervis/Handler/Home.hs | 2 +- src/Vervis/Handler/Repo.hs | 98 +++--- src/Vervis/Readme.hs | 17 +- src/Vervis/SourceTree.hs | 76 +++++ .../{source.cassius => source-darcs.cassius} | 0 templates/repo/source-darcs.hamlet | 57 ++++ templates/repo/source-git.cassius | 295 ++++++++++++++++++ .../repo/{source.hamlet => source-git.hamlet} | 24 +- vervis.cabal | 26 +- 15 files changed, 871 insertions(+), 198 deletions(-) create mode 100644 src/Vervis/Darcs.hs create mode 100644 src/Vervis/GitOld.hs create mode 100644 src/Vervis/SourceTree.hs rename templates/repo/{source.cassius => source-darcs.cassius} (100%) create mode 100644 templates/repo/source-darcs.hamlet create mode 100644 templates/repo/source-git.cassius rename templates/repo/{source.hamlet => source-git.hamlet} (67%) diff --git a/config/routes b/config/routes index 09baab8..ec172c9 100644 --- a/config/routes +++ b/config/routes @@ -43,7 +43,7 @@ /u/#Text/r ReposR GET POST /u/#Text/r/!new RepoNewR GET /u/#Text/r/#Text RepoR GET -/u/#Text/r/#Text/s/#Text/+Texts RepoSourceR GET +/u/#Text/r/#Text/s/+Texts RepoSourceR GET /u/#Text/r/#Text/c RepoCommitsR GET /u/#Text/r/#Text/git/info/refs GitRefDiscoverR GET diff --git a/src/Darcs/Local.hs b/src/Darcs/Local.hs index 1c405dd..10939e8 100644 --- a/src/Darcs/Local.hs +++ b/src/Darcs/Local.hs @@ -14,17 +14,24 @@ -} module Darcs.Local - ( createRepo + ( -- * Initialize new repo + createRepo + -- * View repo source + , readPristineRoot ) where import Prelude +import Storage.Hashed.Hash import System.Directory (createDirectory) import System.Exit (ExitCode (..)) import System.FilePath (()) +import System.IO (withFile, IOMode (ReadMode)) import System.Process (createProcess, proc, waitForProcess) +import qualified Data.ByteString as B + {- initialRepoTree :: FileName -> DirTree B.ByteString initialRepoTree repo = @@ -63,3 +70,55 @@ createRepo parent name = do case ec of ExitSuccess -> return () ExitFailure n -> error $ "darcs init failed with exit code " ++ show n + +{-data DirEntry = DirEntry + { dentType :: ItemType + , dentName :: Name + , dentSize :: Maybe Int + , dentHash :: Hash + } + +data DirEntryView = DirEntryView + { devName :: Name + , devSize :: Maybe Size + , devHash :: Hash + , devContent :: Either BL.ByteString [DirEntry] + } + +data PathView + = RootView [DirEntry] + | TreeView Text Hash [DirEntry] + | BlobView Text Hash BL.ByteString +-} + +readPristineRoot :: FilePath -> IO (Maybe Int, Hash) +readPristineRoot darcsDir = do + let inventoryFile = darcsDir "hashed_inventory" + line <- withFile inventoryFile ReadMode B.hGetLine + let hashBS = B.drop 9 line + return (Nothing, decodeBase16 hashBS) + +{-toDEnt :: (ItemType, Name, Maybe Int, Hash) -> DirEntry +toDEnt (it, n, ms, h) = DirEntry it n ms h + +readSourceRootDir :: FilePath -> (Maybe Int, Hash) -> IO [DirEntry] +readSourceRootDir darcsDir (size, hash) = + let pristineDir = darcsDir "pristine.hashed" + in map toDEnt <$> readDarcsHashedDir pristineDir (size, hash) + +findDirEntry :: Name -> [DirEntry] -> Maybe DirEntry +findDirEntry name = find ((== name) . dentName) + +viewDirEntry :: FilePath -> DirEntry -> IO DirEntryView +viewDirEntry pristineDir (DirEntry itype name size hash) = do + content <- case itype of + TreeType -> + BlobType -> fmap decompress . readSegment . darcsLocation pristineDir + return (name, size, hash, content) + +textToName :: Text -> Name +textToName = Name . encodeUtf8 + +viewPath :: FilePath -> [Name] -> IO PathView +viewPath repoPath sourcePath = --TODO +-} diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs new file mode 100644 index 0000000..cd5df58 --- /dev/null +++ b/src/Vervis/Darcs.hs @@ -0,0 +1,103 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Darcs + ( readSourceView + ) +where + +import Prelude + +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (strictDecode) +import Data.Traversable (for) +import Storage.Hashed.AnchoredPath +import Storage.Hashed.Darcs +import Storage.Hashed.Tree +import System.FilePath (()) + +import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Data.Foldable as F (find) + +import Darcs.Local +import Vervis.Foundation (Widget) +import Vervis.Readme +import Vervis.SourceTree + +dirToAnchoredPath :: [EntryName] -> AnchoredPath +dirToAnchoredPath = AnchoredPath . map (Name . encodeUtf8) + +matchType :: ItemType -> EntryType +matchType TreeType = TypeTree +matchType BlobType = TypeBlob + +nameToText :: Name -> Text +nameToText (Name b) = decodeUtf8With strictDecode b + +itemToEntry :: Name -> TreeItem IO -> DirEntry +itemToEntry name item = DirEntry (matchType $ itemType item) (nameToText name) + +findReadme :: [(Name, TreeItem IO)] -> IO (Maybe (Text, BL.ByteString)) +findReadme pairs = + case F.find (isReadme . nameToText . fst) pairs of + Nothing -> return Nothing + Just (name, item) -> + case item of + File (Blob load _hash) -> do + content <- load + return $ Just (nameToText name, content) + _ -> return Nothing + +itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView BL.ByteString) +itemToSourceView name (File (Blob load _hash)) = do + content <- load + return $ SourceFile $ FileView name content +itemToSourceView name (SubTree tree) = do + let items = listImmediate tree + mreadme <- findReadme items + return $ SourceDir DirectoryView + { dvName = Just name + , dvEntries = map (uncurry itemToEntry) items + , dvReadme = mreadme + } +itemToSourceView _name (Stub _load _hash) = error "supposed to be expanded" + +readSourceView + :: FilePath + -- ^ Repository path + -> [EntryName] + -- ^ Path in the source tree pointing to a file or directory + -> IO (Maybe (SourceView Widget)) +readSourceView path dir = do + let darcsDir = path "_darcs" + (msize, hash) <- readPristineRoot darcsDir + let pristineDir = darcsDir "pristine.hashed" + stubbedTree <- readDarcsHashed pristineDir (msize, hash) + msv <- if null dir + then do + let items = listImmediate stubbedTree + mreadme <- findReadme items + return $ Just $ SourceDir DirectoryView + { dvName = Nothing + , dvEntries = map (uncurry itemToEntry) items + , dvReadme = mreadme + } + else do + let anch = dirToAnchoredPath dir + expandedTree <- expandPath stubbedTree anch + let mitem = find expandedTree anch + for mitem $ itemToSourceView (last dir) + return $ renderSources dir <$> msv diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index b355b98..204e266 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -267,11 +267,11 @@ instance YesodBreadcrumbs App where ReposR shar -> ("Repos", Just $ PersonR shar) RepoNewR shar -> ("New", Just $ ReposR shar) RepoR shar repo -> (repo, Just $ ReposR shar) - RepoSourceR shar repo branch [] -> ("Files", Just $ RepoR shar repo) - RepoSourceR shar repo branch dir -> ( last dir + RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo) + RepoSourceR shar repo refdir -> ( last refdir , Just $ - RepoSourceR shar repo branch $ - init dir + RepoSourceR shar repo $ + init refdir ) RepoCommitsR shar repo -> ("History", Just $ RepoR shar repo) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 1e76a26..7ff6081 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -13,112 +13,100 @@ - . -} -{- LANGUAGE OverloadedStrings #-} -{- LANGUAGE GeneralizedNewtypeDeriving #-} -{- LANGUAGE DeriveGeneric #-} - module Vervis.Git - ( lastChange - , timeAgo - , timeAgo' + ( readSourceView ) where import Prelude -import Control.Monad (join) --- import Control.Monad.Fix (MonadFix) --- import Control.Monad.IO.Class --- import Control.Monad.Trans.RWS (RWST (..)) --- import Data.CaseInsensitive (CI) -import Data.Foldable (toList) +import Data.Foldable (find) import Data.Git -import Data.Git.Revision -import Data.Git.Repository --- import Data.Hashable (Hashable) --- import Data.HashMap.Lazy (HashMap) --- import Data.HashSet (HashSet) -import Data.Hourglass -import Data.Maybe (fromMaybe{-, mapMaybe-}) -import Data.Monoid ((<>)) -import Data.Text (Text) --- import Data.Time.Units --- import GHC.Generics --- import System.Directory.Tree hiding (name, file, err) --- import System.FilePath (()) -import System.Hourglass (dateCurrent) +import Data.Git.Harder +import Data.Git.Storage (getObject_) +import Data.Git.Storage.Object (Object (..)) +import Data.Set (Set) +import Data.String (fromString) +import Data.Text (Text, unpack, pack) +import Data.Text.Encoding (encodeUtf8) --- import qualified Control.Monad.Trans.RWS as RWS --- import qualified Data.CaseInsensitive as CI --- import qualified Data.HashMap.Lazy as M -import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Data.Set as S (member, mapMonotonic) --- | Return the subdirs of a given dir -{-subdirs :: FilePath -> IO [FilePath] -subdirs dir = do - _base :/ tree <- buildL dir - return $ case tree of - Dir _ cs -> - let dirName (Dir n _) = Just n - dirName _ = Nothing - in mapMaybe dirName cs - _ -> []-} +import Data.Git.Local +import Vervis.Foundation (Widget) +import Vervis.Readme +import Vervis.SourceTree --- | Determine the time of the last commit in a given git branch -lastBranchChange :: Git -> String -> IO GitTime -lastBranchChange git branch = do - mref <- resolveRevision git $ Revision branch [] - mco <- traverse (getCommitMaybe git) mref - let mtime = fmap (personTime . commitCommitter) (join mco) - return $ fromMaybe (error "mtime is Nothing") mtime +matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool +matchReadme (_, _, name, EntObjBlob) = isReadme name +matchReadme _ = False --- | Determine the time of the last commit in any branch for a given repo -lastChange :: FilePath -> IO (Maybe DateTime) -lastChange path = withRepo (fromString path) $ \ git -> do - --TODO add a better intro to json-state, the docs are bad there +-- | Find a README file in a directory. Return the filename and the file +-- content. +findReadme :: Git -> TreeRows -> IO (Maybe (Text, BL.ByteString)) +findReadme git rows = + case find matchReadme rows of + Nothing -> return Nothing + Just (_perm, oid, name, _etype) -> do + obj <- getObject_ git (unObjId oid) True + return $ case obj of + ObjBlob b -> Just (name, blobGetContent b) + _ -> Nothing - names <- branchList git - times <- traverse (lastBranchChange git) $ map refNameRaw $ toList names - let datetimes = map timeConvert times - return $ if null datetimes - then Nothing - else Just $ maximum datetimes +matchType :: EntObjType -> EntryType +matchType EntObjBlob = TypeBlob +matchType EntObjTree = TypeTree -showPeriod :: Period -> Text -showPeriod (Period 0 0 d) = T.pack (show d) <> " days" -showPeriod (Period 0 m _) = T.pack (show m) <> " months" -showPeriod (Period y _ _) = T.pack (show y) <> " years" +rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry +rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name -showDuration :: Duration -> Text -showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) = - case (h, m, s) of - (0, 0, 0) -> "now" - (0, 0, _) -> T.pack (show s) <> " seconds" - (0, _, _) -> T.pack (show m) <> " minutes" - _ -> T.pack (show h) <> " hours" +loadSourceView + :: Git + -> Text + -> [Text] + -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString)) +loadSourceView git refT dir = do + branches <- branchList git + tags <- tagList git + let refS = unpack refT + refN = RefName refS + msv <- if refN `S.member` branches || refN `S.member` tags + then do + tipOid <- resolveName git refS + mtree <- resolveTreeish git $ unObjId tipOid + case mtree of + Nothing -> return Nothing + Just tree -> do + let dir' = map (entName . encodeUtf8) dir + view <- viewPath git tree dir' + Just <$> case view of + RootView rows -> do + mreadme <- findReadme git rows + let ents = map rowToEntry rows + return $ SourceDir $ + DirectoryView Nothing ents mreadme + TreeView name _ rows -> do + mreadme <- findReadme git rows + let ents = map rowToEntry rows + return $ SourceDir $ + DirectoryView (Just name) ents mreadme + BlobView name _ body -> + return $ SourceFile $ FileView name body + else return Nothing + return (branches, tags, msv) -showAgo :: Period -> Duration -> Text -showAgo (Period 0 0 0) d = showDuration d -showAgo p _ = showPeriod p - -fromSec :: Seconds -> (Period, Duration) -fromSec sec = - let d = 3600 * 24 - m = 30 * d - y = 365 * d - fs (Seconds n) = fromIntegral n - (years, yrest) = sec `divMod` Seconds y - (months, mrest) = yrest `divMod` Seconds m - (days, drest) = mrest `divMod` Seconds d - in (Period (fs years) (fs months) (fs days), fst $ fromSeconds drest) - -timeAgo :: DateTime -> IO Text -timeAgo dt = do - now <- dateCurrent - return $ timeAgo' now dt - -timeAgo' :: DateTime -> DateTime -> Text -timeAgo' now dt = - let sec = timeDiff now dt - (period, duration) = fromSec sec - in showAgo period duration +readSourceView + :: FilePath + -- ^ Repository path + -> Text + -- ^ Name of branch or tag + -> [Text] + -- ^ Path in the source tree pointing to a file or directory + -> IO (Set Text, Set Text, Maybe (SourceView Widget)) + -- ^ Branches, tags, view of the selected item +readSourceView path ref dir = do + (bs, ts, msv) <- + withRepo (fromString path) $ \ git -> loadSourceView git ref dir + let toTexts = S.mapMonotonic $ pack . refNameRaw + return (toTexts bs, toTexts ts, renderSources dir <$> msv) diff --git a/src/Vervis/GitOld.hs b/src/Vervis/GitOld.hs new file mode 100644 index 0000000..8c5e3cf --- /dev/null +++ b/src/Vervis/GitOld.hs @@ -0,0 +1,124 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +{- LANGUAGE OverloadedStrings #-} +{- LANGUAGE GeneralizedNewtypeDeriving #-} +{- LANGUAGE DeriveGeneric #-} + +module Vervis.GitOld + ( lastChange + , timeAgo + , timeAgo' + ) +where + +import Prelude + +import Control.Monad (join) +-- import Control.Monad.Fix (MonadFix) +-- import Control.Monad.IO.Class +-- import Control.Monad.Trans.RWS (RWST (..)) +-- import Data.CaseInsensitive (CI) +import Data.Foldable (toList) +import Data.Git +import Data.Git.Revision +import Data.Git.Repository +-- import Data.Hashable (Hashable) +-- import Data.HashMap.Lazy (HashMap) +-- import Data.HashSet (HashSet) +import Data.Hourglass +import Data.Maybe (fromMaybe{-, mapMaybe-}) +import Data.Monoid ((<>)) +import Data.Text (Text) +-- import Data.Time.Units +-- import GHC.Generics +-- import System.Directory.Tree hiding (name, file, err) +-- import System.FilePath (()) +import System.Hourglass (dateCurrent) + +-- import qualified Control.Monad.Trans.RWS as RWS +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T + +-- | Return the subdirs of a given dir +{-subdirs :: FilePath -> IO [FilePath] +subdirs dir = do + _base :/ tree <- buildL dir + return $ case tree of + Dir _ cs -> + let dirName (Dir n _) = Just n + dirName _ = Nothing + in mapMaybe dirName cs + _ -> []-} + +-- | Determine the time of the last commit in a given git branch +lastBranchChange :: Git -> String -> IO GitTime +lastBranchChange git branch = do + mref <- resolveRevision git $ Revision branch [] + mco <- traverse (getCommitMaybe git) mref + let mtime = fmap (personTime . commitCommitter) (join mco) + return $ fromMaybe (error "mtime is Nothing") mtime + +-- | Determine the time of the last commit in any branch for a given repo +lastChange :: FilePath -> IO (Maybe DateTime) +lastChange path = withRepo (fromString path) $ \ git -> do + --TODO add a better intro to json-state, the docs are bad there + + names <- branchList git + times <- traverse (lastBranchChange git) $ map refNameRaw $ toList names + let datetimes = map timeConvert times + return $ if null datetimes + then Nothing + else Just $ maximum datetimes + +showPeriod :: Period -> Text +showPeriod (Period 0 0 d) = T.pack (show d) <> " days" +showPeriod (Period 0 m _) = T.pack (show m) <> " months" +showPeriod (Period y _ _) = T.pack (show y) <> " years" + +showDuration :: Duration -> Text +showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) = + case (h, m, s) of + (0, 0, 0) -> "now" + (0, 0, _) -> T.pack (show s) <> " seconds" + (0, _, _) -> T.pack (show m) <> " minutes" + _ -> T.pack (show h) <> " hours" + +showAgo :: Period -> Duration -> Text +showAgo (Period 0 0 0) d = showDuration d +showAgo p _ = showPeriod p + +fromSec :: Seconds -> (Period, Duration) +fromSec sec = + let d = 3600 * 24 + m = 30 * d + y = 365 * d + fs (Seconds n) = fromIntegral n + (years, yrest) = sec `divMod` Seconds y + (months, mrest) = yrest `divMod` Seconds m + (days, drest) = mrest `divMod` Seconds d + in (Period (fs years) (fs months) (fs days), fst $ fromSeconds drest) + +timeAgo :: DateTime -> IO Text +timeAgo dt = do + now <- dateCurrent + return $ timeAgo' now dt + +timeAgo' :: DateTime -> DateTime -> Text +timeAgo' now dt = + let sec = timeDiff now dt + (period, duration) = fromSec sec + in showAgo period duration diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index 54df127..6b98f2c 100644 --- a/src/Vervis/Handler/Home.hs +++ b/src/Vervis/Handler/Home.hs @@ -21,7 +21,7 @@ where import Vervis.Import hiding (on) import Database.Esqueleto hiding ((==.)) -import Vervis.Git +import Vervis.GitOld import qualified Database.Esqueleto as E ((==.)) diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index e751a83..1270e6a 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -66,7 +66,7 @@ import Data.Git.Local import Text.FilePath.Local (breakExt) import Vervis.Form.Repo import Vervis.Foundation -import Vervis.Git (timeAgo') +import Vervis.GitOld (timeAgo') import Vervis.Path import Vervis.MediaType (chooseMediaType) import Vervis.Model @@ -74,11 +74,14 @@ import Vervis.Model.Repo import Vervis.Readme import Vervis.Render import Vervis.Settings +import Vervis.SourceTree import Vervis.Style import qualified Darcs.Local as D (createRepo) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.Git.Local as G (createRepo) +import qualified Vervis.Darcs as D (readSourceView) +import qualified Vervis.Git as G (readSourceView) getReposR :: Text -> Handler Html getReposR user = do @@ -136,62 +139,19 @@ getRepoR user repo = do Entity sid _s <- getBy404 $ UniqueSharerIdent user Entity _rid r <- getBy404 $ UniqueRepo repo sid return r - getRepoSource repository user repo (repoMainBranch repository) [] + case repoVcs repository of + VCSDarcs -> getDarcsRepoSource repository user repo [] + VCSGit -> + getGitRepoSource + repository user repo (repoMainBranch repository) [] -data SourceView a - = DirectoryView (Maybe Text) TreeRows (Maybe (Text, a)) - | FileView Text a - -loadSourceView - :: Git - -> Text - -> [Text] - -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString)) -loadSourceView git refT dir = do - branches <- branchList git - tags <- tagList git - let refS = unpack refT - refN = RefName refS - msv <- if refN `S.member` branches || refN `S.member` tags - then do - tipOid <- resolveName git refS - mtree <- resolveTreeish git $ unObjId tipOid - case mtree of - Nothing -> return Nothing - Just tree -> do - let dir' = map (entName . encodeUtf8) dir - view <- viewPath git tree dir' - Just <$> case view of - RootView rows -> do - mreadme <- findReadme git rows - return $ DirectoryView Nothing rows mreadme - TreeView name _ rows -> do - mreadme <- findReadme git rows - return $ DirectoryView (Just name) rows mreadme - BlobView name _ body -> return $ FileView name body - else return Nothing - return (branches, tags, msv) - -renderSources :: [Text] -> SourceView BL.ByteString -> SourceView Widget -renderSources dir (DirectoryView mname rows mreadme) = - case mreadme of - Nothing -> DirectoryView mname rows Nothing - Just (name, body) -> - DirectoryView mname rows $ Just (name, renderReadme dir name body) -renderSources dir (FileView name body) = - let parent = init dir - (base, ext) = breakExt name - mediaType = chooseMediaType parent base ext () () - in FileView name $ renderSourceBL mediaType body - -getRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html -getRepoSource repository user repo ref dir = do +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 - (branches, tags, msv) <- liftIO $ withRepo (fromString path) $ \ git -> - loadSourceView git ref dir - case renderSources dir <$> msv of + --let toText = decodeUtf8With lenientDecode + -- toTextL = L.decodeUtf8With lenientDecode + msv <- liftIO $ D.readSourceView path dir + case msv of Nothing -> notFound Just sv -> do let parent = if null dir then [] else init dir @@ -199,15 +159,35 @@ getRepoSource repository user repo ref dir = do defaultLayout $ do setTitle $ toHtml $ intercalate " > " $ ["Vervis", "People", user, "Repos", repo] - $(widgetFile "repo/source") + $(widgetFile "repo/source-darcs") -getRepoSourceR :: Text -> Text -> Text -> [Text] -> Handler Html -getRepoSourceR user repo ref dir = do +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 + Just sv -> do + let parent = if null dir then [] else init dir + dirs = zip parent (tail $ inits parent) + defaultLayout $ do + setTitle $ toHtml $ intercalate " > " $ + ["Vervis", "People", user, "Repos", repo] + $(widgetFile "repo/source-git") + +getRepoSourceR :: Text -> Text -> [Text] -> Handler Html +getRepoSourceR user repo refdir = do repository <- runDB $ do Entity sid _s <- getBy404 $ UniqueSharerIdent user Entity _rid r <- getBy404 $ UniqueRepo repo sid return r - getRepoSource repository user repo ref dir + case repoVcs repository of + VCSDarcs -> getDarcsRepoSource repository user repo refdir + VCSGit -> case refdir of + [] -> notFound + (ref:dir) -> getGitRepoSource repository user repo ref dir getRepoCommitsR :: Text -> Text -> Handler Html getRepoCommitsR user repo = do diff --git a/src/Vervis/Readme.hs b/src/Vervis/Readme.hs index 241a87d..c5ddd01 100644 --- a/src/Vervis/Readme.hs +++ b/src/Vervis/Readme.hs @@ -15,7 +15,7 @@ -- | Tools for rendering README files in repository tree view. module Vervis.Readme - ( findReadme + ( isReadme , renderReadme ) where @@ -43,21 +43,6 @@ isReadme file = let basename = takeWhile (not . isExtSeparator) file in toCaseFold "readme" == toCaseFold basename --- | Find a README file in a directory. Return the filename and the file --- content. -findReadme :: Git -> TreeRows -> IO (Maybe (Text, ByteString)) -findReadme git rows = go rows - where - go [] = return Nothing - go ((_perm, oid, name, ref) : es) = - if isReadme name - then do - obj <- getObject_ git (unObjId oid) True - case obj of - ObjBlob b -> return $ Just (name, blobGetContent b) - _ -> go es - else go es - -- | Render README content into a widget for inclusion in a page. renderReadme :: [Text] -> Text -> ByteString -> Widget renderReadme dir name content = diff --git a/src/Vervis/SourceTree.hs b/src/Vervis/SourceTree.hs new file mode 100644 index 0000000..c7baada --- /dev/null +++ b/src/Vervis/SourceTree.hs @@ -0,0 +1,76 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | A representation of a node (file or directory) in a file tree managed by +-- version control. +module Vervis.SourceTree + ( EntryType (..) + , EntryName + , DirEntry (..) + , DirectoryView (..) + , FileView (..) + , SourceView (..) + , renderSources + ) +where + +import Prelude + +import Data.Text (Text) + +import qualified Data.ByteString.Lazy as BL (ByteString) + +import Text.FilePath.Local (breakExt) +import Vervis.Foundation (Widget) +import Vervis.MediaType (chooseMediaType) +import Vervis.Readme (renderReadme) +import Vervis.Render (renderSourceBL) + +data EntryType = TypeBlob | TypeTree + +type EntryName = Text + +data DirEntry = DirEntry + { deType :: EntryType + , deName :: EntryName +-- , deHash :: B.ByteString + } + +data DirectoryView a = DirectoryView + { dvName :: Maybe EntryName + , dvEntries :: [DirEntry] + , dvReadme :: Maybe (EntryName, a) + } + +data FileView a = FileView + { fvName :: EntryName + , fvContent :: a + } + +data SourceView a + = SourceDir (DirectoryView a) + | SourceFile (FileView a) + +renderSources :: [EntryName] -> SourceView BL.ByteString -> SourceView Widget +renderSources dir (SourceDir (DirectoryView mname rows mreadme)) = + SourceDir $ case mreadme of + Nothing -> DirectoryView mname rows Nothing + Just (name, body) -> + DirectoryView mname rows $ Just (name, renderReadme dir name body) +renderSources dir (SourceFile (FileView name body)) = + let parent = init dir + (base, ext) = breakExt name + mediaType = chooseMediaType parent base ext () () + in SourceFile $ FileView name $ renderSourceBL mediaType body diff --git a/templates/repo/source.cassius b/templates/repo/source-darcs.cassius similarity index 100% rename from templates/repo/source.cassius rename to templates/repo/source-darcs.cassius diff --git a/templates/repo/source-darcs.hamlet b/templates/repo/source-darcs.hamlet new file mode 100644 index 0000000..3ce9c98 --- /dev/null +++ b/templates/repo/source-darcs.hamlet @@ -0,0 +1,57 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +$maybe desc <- repoDesc repository +

#{desc} + +

+ Commits + +

Branches + +

TODO + +

Tags + +

TODO + +

+ $forall (piece, piecePath) <- dirs + #{piece} + / # + +$case sv + $of SourceFile (FileView name body) +

#{name} + ^{body} + $of SourceDir (DirectoryView mname ents mreadme) +

#{fromMaybe "Files" mname} + + + +
Type + Name + $forall DirEntry type' name <- ents +
+ $case type' + $of TypeBlob + [F] + $of TypeTree + [D] + + + #{name} + $maybe (readmeName, readmeWidget) <- mreadme +

#{readmeName} + ^{readmeWidget} diff --git a/templates/repo/source-git.cassius b/templates/repo/source-git.cassius new file mode 100644 index 0000000..4b1cb13 --- /dev/null +++ b/templates/repo/source-git.cassius @@ -0,0 +1,295 @@ +/* This file is part of Vervis. + * + * Written in 2016 by fr33domlover . + * + * ♡ Copying is an act of love. Please copy, reuse and share. + * + * The author(s) have dedicated all copyright and related and neighboring + * rights to this software to the public domain worldwide. This software is + * distributed without any warranty. + * + * You should have received a copy of the CC0 Public Domain Dedication along + * with this software. If not, see + * . + */ + +/* Comment */ +.c + color: #ff0000 + background-color: #ffffff + +/* Error */ +.err + color: #ff0000 + background-color: #ffffff + +/* Keyword */ +.k + color: #{dark magenta} + +/* Comment.Multiline */ +.cm + color: #{dark blue} + +/* Comment.Preproc */ +.cp + color: #ff0000 + background-color: #ffffff + +/* Comment.Single */ +.c1 + color: #{dark blue} + +/* Comment.Special */ +.cs + color: #ff0000 + background-color: #ffffff + +/* Generic.Deleted */ +.gd + color: #ff0000 + background-color: #ffffff + +/* Generic.Emph */ +.ge + font-style: italic + +/* Generic.Error */ +.gr + color: #ff0000 + background-color: #ffffff + +/* Generic.Heading */ +.gh + color: #ff0000 + background-color: #ffffff + +/* Generic.Inserted */ +.gi + color: #ff0000 + background-color: #ffffff + +/* Generic.Output */ +.go + color: #ff0000 + background-color: #ffffff + +/* Generic.Prompt */ +.gp + color: #ff0000 + background-color: #ffffff + +/* Generic.Strong */ +.gs + font-weight: bold + +/* Generic.Subheading */ +.gu + color: #ff0000 + background-color: #ffffff + +/* Generic.Traceback */ +.gt + color: #ff0000 + background-color: #ffffff + +/* Keyword.Constant */ +.kc + color: #ff0000 + background-color: #ffffff + +/* Keyword.Declaration */ +.kd + color: #ff0000 + background-color: #ffffff + +/* Keyword.Namespace */ +.kn + color: #ff0000 + background-color: #ffffff + +/* Keyword.Pseudo */ +.kp + color: #ff0000 + background-color: #ffffff + +/* Keyword.Reserved */ +.kr + color: #{dark green} + +/* Keyword.Type */ +.kt + color: #{plain} + +/* Literal.Number */ +.m + color: #ff0000 + background-color: #ffffff + +/* Literal.String */ +.s + color: #{dark red} + +/* Name.Attribute */ +.na + color: #ff0000 + background-color: #ffffff + +/* Name.Builtin */ +.nb + color: #{plain} + +/* Name.Class */ +.nc + color: #ff0000 + background-color: #ffffff + +/* Name.Constant */ +.no + color: #ff0000 + background-color: #ffffff + +/* Name.Decorator */ +.nd + color: #ff0000 + background-color: #ffffff + +/* Name.Exception */ +.ne + color: #ff0000 + background-color: #ffffff + +/* Name.Function */ +.nf + color: #{plain} + +/* Name.Label */ +.nl + color: #ff0000 + background-color: #ffffff + +/* Name.Namespace */ +.nn + color: #{plain} + +/* Name.Property */ +.py + color: #ff0000 + background-color: #ffffff + +/* Name.Tag */ +.nt + color: #ff0000 + background-color: #ffffff + +/* Name.Variable */ +.nv + color: #ff0000 + background-color: #ffffff + +/* Operator.Word */ +.ow + color: #{dark yellow} + +/* Text.Whitespace */ +.w + color: #ff0000 + background-color: #ffffff + +/* Literal.Number.Float */ +.mf + color: #ff0000 + background-color: #ffffff + +/* Literal.Number.Hex */ +.mh + color: #ff0000 + background-color: #ffffff + +/* Literal.Number.Integer */ +.mi + color: #{dark red} + +/* Literal.Number.Oct */ +.mo + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Backtick */ +.sb + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Char */ +.sc + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Doc */ +.sd + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Double */ +.s2 + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Escape */ +.se + color: #{dark magenta} + +/* Literal.String.Heredoc */ +.sh + color: #dd2200 + background-color: #fff0f0 + +/* Literal.String.Interpol */ +.si + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Other */ +.sx + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Regex */ +.sr + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Single */ +.s1 + color: #ff0000 + background-color: #ffffff + +/* Literal.String.Symbol */ +.ss + color: #ff0000 + background-color: #ffffff + +/* Name.Builtin.Pseudo */ +.bp + color: #ff0000 + background-color: #ffffff + +/* Name.Variable.Class */ +.vc + color: #ff0000 + background-color: #ffffff + +/* Name.Variable.Global */ +.vg + color: #ff0000 + background-color: #ffffff + +/* Name.Variable.Instance */ +.vi + color: #ff0000 + background-color: #ffffff + +/* Literal.Number.Integer.Long */ +.il + color: #ff0000 + background-color: #ffffff diff --git a/templates/repo/source.hamlet b/templates/repo/source-git.hamlet similarity index 67% rename from templates/repo/source.hamlet rename to templates/repo/source-git.hamlet index eb440a1..507ecef 100644 --- a/templates/repo/source.hamlet +++ b/templates/repo/source-git.hamlet @@ -21,44 +21,44 @@ $maybe desc <- repoDesc repository

Branches