mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-20 15:14:54 +09:00
Split git repo source handler into sane small functions
This commit is contained in:
fr33domlover
parent
2c73158c47
commit
c8c323f695
5 changed files with 149 additions and 115 deletions
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue