Refactor git source view code and implement the same for Darcs

This commit is contained in:
fr33domlover 2016-05-05 07:29:19 +00:00
parent c8c323f695
commit 3ed04941e8
15 changed files with 871 additions and 198 deletions

View file

@ -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

View file

@ -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
-}

103
src/Vervis/Darcs.hs Normal file
View file

@ -0,0 +1,103 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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

View file

@ -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)

View file

@ -13,112 +13,100 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{- 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)

124
src/Vervis/GitOld.hs Normal file
View file

@ -0,0 +1,124 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{- 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

View file

@ -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 ((==.))

View file

@ -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
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

View file

@ -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 =

76
src/Vervis/SourceTree.hs Normal file
View file

@ -0,0 +1,76 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | 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

View file

@ -0,0 +1,57 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
$maybe desc <- repoDesc repository
<p>#{desc}
<p>
<a href=@{RepoCommitsR user repo}>Commits
<h2>Branches
<p>TODO
<h2>Tags
<p>TODO
<div>
$forall (piece, piecePath) <- dirs
<a href=@{RepoSourceR user repo piecePath}>#{piece}
/ #
$case sv
$of SourceFile (FileView name body)
<h2>#{name}
^{body}
$of SourceDir (DirectoryView mname ents mreadme)
<h2>#{fromMaybe "Files" mname}
<table>
<tr>
<th>Type
<th>Name
$forall DirEntry type' name <- ents
<tr>
<td>
$case type'
$of TypeBlob
[F]
$of TypeTree
[D]
<td>
<a href=@{RepoSourceR user repo (dir ++ [name])}>
#{name}
$maybe (readmeName, readmeWidget) <- mreadme
<h2>#{readmeName}
^{readmeWidget}

View file

@ -0,0 +1,295 @@
/* This file is part of Vervis.
*
* Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
*
* ♡ 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
* <http://creativecommons.org/publicdomain/zero/1.0/>.
*/
/* 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

View file

@ -21,44 +21,44 @@ $maybe desc <- repoDesc repository
<h2>Branches
<ul>
$forall RefName branch <- branches
$forall branch <- branches
<li>
<a href=@{RepoSourceR user repo (pack branch) []}>#{branch}
<a href=@{RepoSourceR user repo [branch]}>#{branch}
<h2>Tags
<ul>
$forall RefName tag <- tags
$forall tag <- tags
<li>
<a href=@{RepoSourceR user repo (pack tag) []}>#{tag}
<a href=@{RepoSourceR user repo [tag]}>#{tag}
<div>
<a href=@{RepoSourceR user repo ref []}>#{ref}
<a href=@{RepoSourceR user repo [ref]}>#{ref}
:: #
$forall (piece, piecePath) <- dirs
<a href=@{RepoSourceR user repo ref piecePath}>#{piece}
<a href=@{RepoSourceR user repo (ref : piecePath)}>#{piece}
/ #
$case sv
$of FileView name body
$of SourceFile (FileView name body)
<h2>#{name}
^{body}
$of DirectoryView mname rows mreadme
$of SourceDir (DirectoryView mname ents mreadme)
<h2>#{fromMaybe "Files" mname}
<table>
<tr>
<th>Type
<th>Name
$forall (_perm, _oid, name, type') <- rows
$forall DirEntry type' name <- ents
<tr>
<td>
$case type'
$of EntObjBlob
$of TypeBlob
[F]
$of EntObjTree
$of TypeTree
[D]
<td>
<a href=@{RepoSourceR user repo ref (dir ++ [name])}>
<a href=@{RepoSourceR user repo (ref : (dir ++ [name]))}>
#{name}
$maybe (readmeName, readmeWidget) <- mreadme
<h2>#{readmeName}

View file

@ -47,6 +47,7 @@ library
Vervis.Application
Vervis.BinaryBody
Vervis.Content
Vervis.Darcs
Vervis.Field.Key
Vervis.Field.Person
Vervis.Field.Project
@ -58,15 +59,7 @@ library
Vervis.Form.Ticket
Vervis.Foundation
Vervis.Git
Vervis.Import
Vervis.Import.NoFoundation
Vervis.MediaType
Vervis.Model
Vervis.Model.Repo
Vervis.Readme
Vervis.Render
Vervis.Settings
Vervis.Settings.StaticFiles
Vervis.GitOld
Vervis.Handler.Common
Vervis.Handler.Git
Vervis.Handler.Home
@ -76,7 +69,17 @@ library
Vervis.Handler.Repo
Vervis.Handler.Ticket
Vervis.Handler.Util
Vervis.Import
Vervis.Import.NoFoundation
Vervis.MediaType
Vervis.Model
Vervis.Model.Repo
Vervis.Path
Vervis.Readme
Vervis.Render
Vervis.Settings
Vervis.Settings.StaticFiles
Vervis.SourceTree
Vervis.Ssh
Vervis.Style
Vervis.Widget
@ -100,9 +103,9 @@ library
build-depends: aeson
, attoparsec
, base
, base64-bytestring
-- for Data.Binary.Local
, binary
, base64-bytestring
, blaze-html
, byteable
, bytestring
@ -111,6 +114,9 @@ library
, classy-prelude-conduit
, conduit
, containers
-- for Storage.Hashed because hashed-storage seems
-- unmaintained and darcs has its own copy
, darcs
, data-default
, directory
-- for Data.Git.Local