diff --git a/src/Darcs/Local.hs b/src/Darcs/Local.hs index 13a9d4f..1c405dd 100644 --- a/src/Darcs/Local.hs +++ b/src/Darcs/Local.hs @@ -14,7 +14,7 @@ -} module Darcs.Local - ( initRepo + ( createRepo ) where @@ -48,13 +48,13 @@ initialRepoTree repo = -} -- | initialize a new bare repository at a specific location. -initRepo +createRepo :: FilePath -- ^ Parent directory which already exists -> String -- ^ Name of new repo, i.e. new directory to create under the parent -> IO () -initRepo parent name = do +createRepo parent name = do let path = parent name createDirectory path let settings = proc "darcs" ["init", "--no-working-dir", path] diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index c103518..4d6d047 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.hs @@ -14,44 +14,45 @@ -} module Data.Git.Local - ( initRepo + ( -- * Initialize repo + createRepo + -- * View repo content + , EntObjType (..) + , TreeRows + , PathView (..) + , viewPath ) where import Prelude import Control.Monad (when) +import Data.Byteable (toBytes) +import Data.Git +import Data.Git.Harder +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import System.Directory.Tree import qualified Data.ByteString as B (ByteString, writeFile) - -initialConfig :: B.ByteString -initialConfig = - "[core]\n\ - \ repositoryformatversion = 0\n\ - \ filemode = true\n\ - \ bare = true" - -initialDescription :: B.ByteString -initialDescription = - "Unnamed repository; edit this file to name the repository." - -initialHead :: B.ByteString -initialHead = "ref: refs/heads/master" - -initialExclude :: B.ByteString -initialExclude = "" +import qualified Data.ByteString.Lazy as BL (ByteString) initialRepoTree :: FileName -> DirTree B.ByteString initialRepoTree repo = Dir repo [ Dir "branches" [] - , File "config" initialConfig - , File "description" initialDescription - , File "HEAD" initialHead + , File "config" + "[core]\n\ + \ repositoryformatversion = 0\n\ + \ filemode = true\n\ + \ bare = true" + , File "description" + "Unnamed repository; edit this file to name the repository." + , File "HEAD" "ref: refs/heads/master" , Dir "hooks" [] , Dir "info" - [ File "exclude" initialExclude + [ File "exclude" "" ] , Dir "objects" [ Dir "info" [] @@ -68,14 +69,41 @@ initialRepoTree repo = -- Currently in the @hit@ package, i.e. version 0.6.3, the initRepo function -- creates a directory which the git executable doesn't recognize as a git -- repository. The version here creates a properly initialized repo. -initRepo +createRepo :: FilePath -- ^ Parent directory which already exists -> String -- ^ Name of new repo, i.e. new directory to create under the parent -> IO () -initRepo path name = do +createRepo path name = do let tree = path :/ initialRepoTree name result <- writeDirectoryWith B.writeFile tree let errs = failures $ dirTree result when (not . null $ errs) $ error $ show errs + +data EntObjType = EntObjBlob | EntObjTree + +type TreeRows = [(ModePerm, ObjId, Text, EntObjType)] + +data PathView + = RootView TreeRows + | TreeView Text ObjId TreeRows + | BlobView Text ObjId BL.ByteString + +viewPath :: Git -> Tree -> EntPath -> IO PathView +viewPath git root path = do + let toEnt False = EntObjBlob + toEnt True = EntObjTree + toText = decodeUtf8With lenientDecode . toBytes + adapt (perm, oid, name, isTree) = + (perm, oid, toText name, toEnt isTree) + mkRows t = map adapt <$> viewTree git t + mno <- resolveTreePath git root path + case mno of + Nothing -> RootView <$> mkRows root + Just (name, oid) -> do + let nameT = toText name + target <- getEntryObject_ git oid + case target of + Left blob -> return $ BlobView nameT oid (blobGetContent blob) + Right tree -> TreeView nameT oid <$> mkRows tree diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 8886a6e..e751a83 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -32,20 +32,18 @@ where -- [x] write the git and mkdir parts that actually create the repo -- [x] make repo view that shows a table of commits -import ClassyPrelude.Conduit hiding (last, toStrict, unpack) +import ClassyPrelude.Conduit hiding (last, unpack) import Yesod hiding (Header, parseTime, (==.)) import Yesod.Auth import Prelude (init, last, tail) -import Data.Byteable (toBytes) -import Data.ByteString.Lazy (toStrict) import Data.Git.Graph import Data.Git.Harder import Data.Git.Named (RefName (..)) import Data.Git.Ref (toHex) import Data.Git.Repository -import Data.Git.Storage (withRepo, getObject_) +import Data.Git.Storage (withRepo) import Data.Git.Storage.Object (Object (..)) import Data.Git.Types (Blob (..), Commit (..), Person (..), entName) import Data.Graph.Inductive.Graph (noNodes) @@ -64,6 +62,7 @@ import qualified Data.Set as S (member) import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import Data.ByteString.Char8.Local (takeLine) +import Data.Git.Local import Text.FilePath.Local (breakExt) import Vervis.Form.Repo import Vervis.Foundation @@ -77,8 +76,9 @@ import Vervis.Render import Vervis.Settings import Vervis.Style -import qualified Darcs.Local as D (initRepo) -import qualified Data.Git.Local as G (initRepo) +import qualified Darcs.Local as D (createRepo) +import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Data.Git.Local as G (createRepo) getReposR :: Text -> Handler Html getReposR user = do @@ -105,8 +105,8 @@ postReposR user = do createDirectoryIfMissing True parent let repoName = unpack $ repoIdent repo case repoVcs repo of - VCSDarcs -> D.initRepo parent repoName - VCSGit -> G.initRepo parent repoName + VCSDarcs -> D.createRepo parent repoName + VCSGit -> G.createRepo parent repoName runDB $ insert_ repo setMessage "Repo added." redirect $ ReposR user @@ -138,66 +138,64 @@ getRepoR user repo = do return r getRepoSource 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 path <- askRepoDir user repo let toText = decodeUtf8With lenientDecode toTextL = L.decodeUtf8With lenientDecode - minfo <- liftIO $ withRepo (fromString path) $ \ git -> do - branches <- branchList git - tags <- tagList git - let name = unpack ref - name' = RefName name - if name' `S.member` branches || name' `S.member` tags - then do - tipOid <- resolveName git name - mtree <- resolveTreeish git $ unObjId tipOid - case mtree of - Nothing -> return Nothing - Just tree -> do - let dir' = map (entName . encodeUtf8) dir - mTargetOid <- resolveTreePath git tree dir' - target <- case mTargetOid of - Nothing -> return $ Right tree - Just oid -> do - obj <- getObject_ git (unObjId oid) True - case obj of - ObjTree t -> return $ Right t - ObjBlob b -> return $ Left b - _ -> error "expected tree or blob" - view <- case target of - Left b -> Left <$> return b - Right t -> do - v <- viewTree git t - mreadme <- findReadme git t - let r = case mreadme of - Nothing -> Nothing - Just (t, b) -> - Just (t, renderReadme dir t b) - return $ Right (v, r) - return $ Just (branches, tags, view) - else return Nothing - case minfo of - Nothing -> notFound - Just (branches, tags, view) -> do - let mkrow (_perm, name, isTree) = - ( if isTree then "[D]" else "[F]" :: Text - , toText $ toBytes name - ) - display <- case view of - Left b -> return $ Left $ - let name = last dir - parent = init dir - (base, ext) = breakExt name - mediaType = chooseMediaType parent base ext () () - in renderSourceBL mediaType (blobGetContent b) - Right (v, mr) -> return $ Right (map mkrow v, mr) + (branches, tags, msv) <- liftIO $ withRepo (fromString path) $ \ git -> + loadSourceView git ref dir + case renderSources dir <$> msv of + Nothing -> notFound + Just sv -> do let parent = if null dir then [] else init dir dirs = zip parent (tail $ inits parent) - title = case (dir, display) of - ([], _) -> "Files" - (_, Left _) -> last dir - (_, Right _) -> last dir <> "/" defaultLayout $ do setTitle $ toHtml $ intercalate " > " $ ["Vervis", "People", user, "Repos", repo] diff --git a/src/Vervis/Readme.hs b/src/Vervis/Readme.hs index ed4816d..241a87d 100644 --- a/src/Vervis/Readme.hs +++ b/src/Vervis/Readme.hs @@ -22,20 +22,19 @@ where import Prelude hiding (takeWhile) -import Data.Byteable (toBytes) import Data.ByteString.Lazy (ByteString) +import Data.Git.Harder (ObjId (..)) import Data.Git.Storage (Git, getObject_) import Data.Git.Storage.Object (Object (..)) import Data.Git.Types (Blob (..), Tree (..)) import Data.Text (Text, toCaseFold, takeWhile, unpack) -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (strictDecode) import System.FilePath (isExtSeparator) +import Data.Git.Local (TreeRows) +import Text.FilePath.Local (breakExt) import Vervis.Foundation (Widget) import Vervis.MediaType (chooseMediaType) import Vervis.Render (renderSourceBL) -import Text.FilePath.Local (breakExt) -- | Check if the given filename should be considered as README file. Assumes -- a flat filename which doesn't contain a directory part. @@ -46,19 +45,18 @@ isReadme file = -- | Find a README file in a directory. Return the filename and the file -- content. -findReadme :: Git -> Tree -> IO (Maybe (Text, ByteString)) -findReadme git tree = go $ treeGetEnts tree +findReadme :: Git -> TreeRows -> IO (Maybe (Text, ByteString)) +findReadme git rows = go rows where go [] = return Nothing - go ((_perm, name, ref) : es) = - let nameT = decodeUtf8With strictDecode $ toBytes name - in if isReadme nameT - then do - obj <- getObject_ git ref True - case obj of - ObjBlob b -> return $ Just (nameT, blobGetContent b) - _ -> go es - else go es + 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 diff --git a/templates/repo/source.hamlet b/templates/repo/source.hamlet index 79295ac..eb440a1 100644 --- a/templates/repo/source.hamlet +++ b/templates/repo/source.hamlet @@ -19,34 +19,44 @@ $maybe desc <- repoDesc repository Commits

Branches +