mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-10 01:26:46 +09:00
226 lines
8 KiB
Haskell
226 lines
8 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
|
|
, getRepoHeadChangesR
|
|
, getRepoChangesR
|
|
)
|
|
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, unpack)
|
|
import Yesod hiding (Header, parseTime, (==.))
|
|
import Yesod.Auth
|
|
|
|
import Prelude (init, last, tail)
|
|
|
|
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)
|
|
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
|
|
import Text.FilePath.Local (breakExt)
|
|
import Vervis.Form.Repo
|
|
import Vervis.Foundation
|
|
import Vervis.GitOld (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.SourceTree
|
|
import Vervis.Style
|
|
import Vervis.Widget.Repo
|
|
|
|
import qualified Darcs.Local.Repository 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, readChangesView)
|
|
import qualified Vervis.Git as G (readSourceView, readChangesView)
|
|
|
|
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 -> do
|
|
parent <- askSharerDir user
|
|
liftIO $ do
|
|
createDirectoryIfMissing True parent
|
|
let repoName = unpack $ repoIdent repo
|
|
case repoVcs repo of
|
|
VCSDarcs -> D.createRepo parent repoName
|
|
VCSGit -> G.createRepo parent repoName
|
|
runDB $ insert_ repo
|
|
setMessage "Repo added."
|
|
redirect $ ReposR user
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "repo/repo-new")
|
|
FormFailure _l -> do
|
|
setMessage "Repo creation failed, see errors below"
|
|
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")
|
|
|
|
selectRepo :: Text -> Text -> AppDB Repo
|
|
selectRepo shar repo = do
|
|
Entity sid _s <- getBy404 $ UniqueSharerIdent shar
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
return r
|
|
|
|
getRepoR :: Text -> Text -> Handler Html
|
|
getRepoR shar repo = do
|
|
repository <- runDB $ selectRepo shar repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoSource repository shar repo []
|
|
VCSGit ->
|
|
getGitRepoSource
|
|
repository shar repo (repoMainBranch repository) []
|
|
|
|
getDarcsRepoSource :: Repo -> Text -> Text -> [Text] -> Handler Html
|
|
getDarcsRepoSource repository user repo dir = do
|
|
path <- askRepoDir user repo
|
|
msv <- liftIO $ D.readSourceView path 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-darcs")
|
|
|
|
getGitRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
|
|
getGitRepoSource repository user repo ref dir = do
|
|
path <- askRepoDir user repo
|
|
(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 shar repo refdir = do
|
|
repository <- runDB $ selectRepo shar repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoSource repository shar repo refdir
|
|
VCSGit -> case refdir of
|
|
[] -> notFound
|
|
(ref:dir) -> getGitRepoSource repository shar repo ref dir
|
|
|
|
getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
|
|
getDarcsRepoHeadChanges shar repo = do
|
|
path <- askRepoDir shar repo
|
|
mentries <- liftIO $ D.readChangesView path
|
|
case mentries of
|
|
Nothing -> notFound
|
|
Just entries ->
|
|
let changes = changesW entries
|
|
in defaultLayout $(widgetFile "repo/changes-darcs")
|
|
|
|
getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html
|
|
getGitRepoHeadChanges repository shar repo =
|
|
getGitRepoChanges shar repo $ repoMainBranch repository
|
|
|
|
getRepoHeadChangesR :: Text -> Text -> Handler Html
|
|
getRepoHeadChangesR user repo = do
|
|
repository <- runDB $ selectRepo user repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoHeadChanges user repo
|
|
VCSGit -> getGitRepoHeadChanges repository user repo
|
|
|
|
getDarcsRepoChanges :: Text -> Text -> Text -> Handler Html
|
|
getDarcsRepoChanges shar repo tag = notFound
|
|
|
|
getGitRepoChanges :: Text -> Text -> Text -> Handler Html
|
|
getGitRepoChanges shar repo ref = do
|
|
path <- askRepoDir shar repo
|
|
(branches, tags, mentries) <- liftIO $ G.readChangesView path ref
|
|
case mentries of
|
|
Nothing -> notFound
|
|
Just entries ->
|
|
let refSelect = refSelectW shar repo branches tags
|
|
changes = changesW entries
|
|
in defaultLayout $(widgetFile "repo/changes-git")
|
|
|
|
getRepoChangesR :: Text -> Text -> Text -> Handler Html
|
|
getRepoChangesR shar repo ref = do
|
|
repository <- runDB $ selectRepo shar repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoChanges shar repo ref
|
|
VCSGit -> getGitRepoChanges shar repo ref
|