mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-09 13:26:45 +09:00
239 lines
9.2 KiB
Haskell
239 lines
9.2 KiB
Haskell
{- 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.Handler.Repo
|
|
( getReposR
|
|
, postReposR
|
|
, getRepoNewR
|
|
, getRepoR
|
|
, getRepoSourceR
|
|
, getRepoCommitsR
|
|
)
|
|
where
|
|
|
|
--TODO CONTINUE HERE
|
|
--
|
|
-- [/] maybe list project repos in personal overview too
|
|
-- [x] make repo list page
|
|
-- [x] add new repo creation link
|
|
-- [x] make new repo form
|
|
-- [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 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 hiding (initRepo)
|
|
import Data.Git.Storage (withRepo, getObject_)
|
|
import Data.Git.Storage.Object (Object (..))
|
|
import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
|
|
import Data.Graph.Inductive.Graph (noNodes)
|
|
import Data.Graph.Inductive.Query.Topsort
|
|
import Data.List (inits)
|
|
import Data.Text (unpack)
|
|
import Data.Text.Encoding (decodeUtf8With)
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
|
import Database.Esqueleto
|
|
import Data.Hourglass (timeConvert)
|
|
import System.Directory (createDirectoryIfMissing)
|
|
import System.Hourglass (dateCurrent)
|
|
|
|
import qualified Data.DList as D
|
|
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 (initRepo)
|
|
import Text.FilePath.Local (breakExt)
|
|
import Vervis.Form.Repo
|
|
import Vervis.Foundation
|
|
import Vervis.Git (timeAgo')
|
|
import Vervis.Path
|
|
import Vervis.MediaType (chooseMediaType)
|
|
import Vervis.Model
|
|
import Vervis.Model.Repo
|
|
import Vervis.Readme
|
|
import Vervis.Render
|
|
import Vervis.Settings
|
|
import Vervis.Style
|
|
|
|
getReposR :: Text -> Handler Html
|
|
getReposR user = do
|
|
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
|
|
where_ $
|
|
sharer ^. SharerIdent ==. val user &&.
|
|
sharer ^. SharerId ==. repo ^. RepoSharer
|
|
orderBy [asc $ repo ^. RepoIdent]
|
|
return $ repo ^. RepoIdent
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ intercalate " > "
|
|
["Vervis", "People", user, "Repos"]
|
|
$(widgetFile "repo/repos")
|
|
|
|
postReposR :: Text -> Handler Html
|
|
postReposR user = do
|
|
Entity _pid person <- requireAuth
|
|
let sid = personIdent person
|
|
((result, widget), enctype) <- runFormPost $ newRepoForm sid
|
|
case result of
|
|
FormSuccess repo ->
|
|
case repoVcs repo of
|
|
VCSDarcs -> error "Darcs not supported yet"
|
|
VCSGit -> do
|
|
parent <- askSharerDir user
|
|
liftIO $ do
|
|
createDirectoryIfMissing True parent
|
|
initRepo parent (unpack $ repoIdent repo)
|
|
runDB $ insert_ repo
|
|
setMessage "Repo added."
|
|
redirect $ ReposR user
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "repo/repo-new")
|
|
FormFailure l -> do
|
|
setMessage $ toHtml $ intercalate "; " l
|
|
defaultLayout $(widgetFile "repo/repo-new")
|
|
|
|
getRepoNewR :: Text -> Handler Html
|
|
getRepoNewR user = do
|
|
Entity _pid person <- requireAuth
|
|
let sid = personIdent person
|
|
((_result, widget), enctype) <- runFormPost $ newRepoForm sid
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
|
|
$(widgetFile "repo/repo-new")
|
|
|
|
instance ResultList D.DList where
|
|
emptyList = D.empty
|
|
appendItem = flip D.snoc
|
|
|
|
getRepoR :: Text -> Text -> Handler Html
|
|
getRepoR user repo = do
|
|
repository <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharerIdent user
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
return r
|
|
getRepoSource repository user repo (repoMainBranch repository) []
|
|
|
|
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)
|
|
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]
|
|
$(widgetFile "repo/source")
|
|
|
|
getRepoSourceR :: Text -> Text -> Text -> [Text] -> Handler Html
|
|
getRepoSourceR user repo ref dir = 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
|
|
|
|
getRepoCommitsR :: Text -> Text -> Handler Html
|
|
getRepoCommitsR user repo = do
|
|
repository <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharerIdent user
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
return r
|
|
path <- askRepoDir user repo
|
|
pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
|
|
oid <- resolveName git $ unpack $ repoMainBranch repository
|
|
graph <- loadCommitGraphPT git [oid]
|
|
let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
|
|
nodes = case mnodes of
|
|
Nothing -> error "commit graph contains a cycle"
|
|
Just ns -> ns
|
|
return $ D.toList $ fmap (nodeLabel graph) nodes
|
|
now <- liftIO dateCurrent
|
|
let toText = decodeUtf8With lenientDecode
|
|
mkrow oid commit =
|
|
( toText $ personName $ commitAuthor commit
|
|
, toText $ toHex $ unObjId oid
|
|
, toText $ takeLine $ commitMessage commit
|
|
, timeAgo' now (timeConvert $ personTime $ commitAuthor commit)
|
|
)
|
|
rows = map (uncurry mkrow) pairs
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ intercalate " > "
|
|
["Vervis", "People", user, "Repos", repo, "Commits"]
|
|
$(widgetFile "repo/commits")
|