mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-08 20:06:45 +09:00
357 lines
13 KiB
Haskell
357 lines
13 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018 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
|
|
, putRepoR
|
|
, deleteRepoR
|
|
, postRepoR
|
|
, getRepoEditR
|
|
, getRepoSourceR
|
|
, getRepoHeadChangesR
|
|
, getRepoChangesR
|
|
, getRepoPatchR
|
|
, getRepoDevsR
|
|
, postRepoDevsR
|
|
, getRepoDevNewR
|
|
, getRepoDevR
|
|
, deleteRepoDevR
|
|
, postRepoDevR
|
|
, getDarcsDownloadR
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Logger (logWarn)
|
|
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 (Text, unpack)
|
|
import Data.Text.Encoding (decodeUtf8With)
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
|
import Data.Traversable (for)
|
|
import Database.Esqueleto hiding (delete, (%))
|
|
import Database.Persist (delete)
|
|
import Data.Hourglass (timeConvert)
|
|
import Formatting (sformat, stext, (%))
|
|
import System.Directory
|
|
import System.Hourglass (dateCurrent)
|
|
import Text.Blaze.Html (Html)
|
|
import Yesod.Auth (requireAuthId)
|
|
import Yesod.Core (defaultLayout, setMessage)
|
|
import Yesod.Core.Content (TypedContent)
|
|
import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core (runDB, getBy404)
|
|
|
|
import qualified Data.CaseInsensitive as CI (foldedCase)
|
|
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.Handler.Repo.Darcs
|
|
import Vervis.Handler.Repo.Git
|
|
import Vervis.Path
|
|
import Vervis.MediaType (chooseMediaType)
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Model.Repo
|
|
import Vervis.Paginate
|
|
import Vervis.Readme
|
|
import Vervis.Render
|
|
import Vervis.Settings
|
|
import Vervis.SourceTree
|
|
import Vervis.Style
|
|
import Vervis.Widget.Repo
|
|
import Vervis.Widget.Sharer
|
|
|
|
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.Formatting as F
|
|
|
|
getReposR :: ShrIdent -> 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 $(widgetFile "repo/list")
|
|
|
|
postReposR :: ShrIdent -> Handler Html
|
|
postReposR user = do
|
|
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
|
((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
|
case result of
|
|
FormSuccess nrp -> do
|
|
parent <- askSharerDir user
|
|
liftIO $ do
|
|
createDirectoryIfMissing True parent
|
|
let repoName =
|
|
unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
|
|
case nrpVcs nrp of
|
|
VCSDarcs -> D.createRepo parent repoName
|
|
VCSGit -> G.createRepo parent repoName
|
|
pid <- requireAuthId
|
|
runDB $ do
|
|
let repo = Repo
|
|
{ repoIdent = nrpIdent nrp
|
|
, repoSharer = sid
|
|
, repoVcs = nrpVcs nrp
|
|
, repoProject = nrpProj nrp
|
|
, repoDesc = nrpDesc nrp
|
|
, repoMainBranch = "master"
|
|
}
|
|
rid <- insert repo
|
|
let collab = RepoCollab
|
|
{ repoCollabRepo = rid
|
|
, repoCollabPerson = pid
|
|
, repoCollabRole = nrpRole nrp
|
|
}
|
|
insert_ collab
|
|
setMessage "Repo added."
|
|
redirect $ ReposR user
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "repo/new")
|
|
FormFailure _l -> do
|
|
setMessage "Repo creation failed, see errors below"
|
|
defaultLayout $(widgetFile "repo/new")
|
|
|
|
getRepoNewR :: ShrIdent -> Handler Html
|
|
getRepoNewR user = do
|
|
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
|
((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
|
defaultLayout $(widgetFile "repo/new")
|
|
|
|
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
|
|
selectRepo shar repo = do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
return r
|
|
|
|
getRepoR :: ShrIdent -> RpIdent -> 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) []
|
|
|
|
putRepoR :: ShrIdent -> RpIdent -> Handler Html
|
|
putRepoR shr rp = do
|
|
mer <- runDB $ do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
er@(Entity rid r) <- getBy404 $ UniqueRepo rp sid
|
|
mwiki <- for (repoProject r) $ \ jid -> do
|
|
project <- getJust jid
|
|
return $ (== rid) <$> projectWiki project
|
|
return $ case mwiki of
|
|
Just (Just True) -> Nothing
|
|
_ -> Just er
|
|
case mer of
|
|
Nothing -> do
|
|
setMessage "Repo used as a wiki, can't move between projects."
|
|
redirect $ RepoR shr rp
|
|
Just er@(Entity rid _) -> do
|
|
((result, widget), enctype) <- runFormPost $ editRepoForm er
|
|
case result of
|
|
FormSuccess repository' -> do
|
|
runDB $ replace rid repository'
|
|
setMessage "Repository updated."
|
|
redirect $ RepoR shr rp
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing."
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
FormFailure _l -> do
|
|
setMessage "Repository update failed, see errors below."
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
|
|
deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
|
|
deleteRepoR shar repo = do
|
|
runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity rid _r <- getBy404 $ UniqueRepo repo sid
|
|
delete rid
|
|
path <- askRepoDir shar repo
|
|
exists <- liftIO $ doesDirectoryExist path
|
|
if exists
|
|
then liftIO $ removeDirectoryRecursive path
|
|
else
|
|
$logWarn $ sformat
|
|
( "Deleted repo " % F.sharer % "/" % F.repo
|
|
% " from DB but repo dir doesn't exist"
|
|
)
|
|
shar repo
|
|
setMessage "Repo deleted."
|
|
redirect HomeR
|
|
|
|
postRepoR :: ShrIdent -> RpIdent -> Handler Html
|
|
postRepoR shar repo = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "PUT" -> putRepoR shar repo
|
|
Just "DELETE" -> deleteRepoR shar repo
|
|
_ -> notFound
|
|
|
|
getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
|
|
getRepoEditR shr rp = do
|
|
er <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
getBy404 $ UniqueRepo rp s
|
|
((_result, widget), enctype) <- runFormPost $ editRepoForm er
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
|
|
getRepoSourceR :: ShrIdent -> RpIdent -> [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
|
|
|
|
getRepoHeadChangesR :: ShrIdent -> RpIdent -> Handler TypedContent
|
|
getRepoHeadChangesR user repo = do
|
|
repository <- runDB $ selectRepo user repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoHeadChanges user repo
|
|
VCSGit -> getGitRepoHeadChanges repository user repo
|
|
|
|
getRepoChangesR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
|
|
getRepoChangesR shar repo ref = do
|
|
repository <- runDB $ selectRepo shar repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> getDarcsRepoChanges shar repo ref
|
|
VCSGit -> getGitRepoChanges shar repo ref
|
|
|
|
getRepoPatchR :: ShrIdent -> RpIdent -> Text -> Handler Html
|
|
getRepoPatchR shr rp ref = do
|
|
repository <- runDB $ selectRepo shr rp
|
|
case repoVcs repository of
|
|
VCSDarcs -> error "Not implemented yet" -- getDarcsPatch shr rp ref
|
|
VCSGit -> getGitPatch shr rp ref
|
|
|
|
getRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
|
getRepoDevsR shr rp = do
|
|
devs <- runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
select $ from $ \ (collab, person, sharer, role) -> do
|
|
where_ $
|
|
collab ^. RepoCollabRepo ==. val rid &&.
|
|
collab ^. RepoCollabPerson ==. person ^. PersonId &&.
|
|
person ^. PersonIdent ==. sharer ^. SharerId &&.
|
|
collab ^. RepoCollabRole ==. role ^. RepoRoleId
|
|
return (sharer, role ^. RepoRoleIdent)
|
|
defaultLayout $(widgetFile "repo/collab/list")
|
|
|
|
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
|
postRepoDevsR shr rp = do
|
|
(sid, mjid, rid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
|
return (s, repoProject repository, r)
|
|
((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid
|
|
case result of
|
|
FormSuccess nc -> do
|
|
runDB $ do
|
|
let collab = RepoCollab
|
|
{ repoCollabRepo = rid
|
|
, repoCollabPerson = ncPerson nc
|
|
, repoCollabRole = ncRole nc
|
|
}
|
|
insert_ collab
|
|
setMessage "Collaborator added."
|
|
redirect $ RepoDevsR shr rp
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
FormFailure _l -> do
|
|
setMessage "Operation failed, see errors below"
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
|
|
getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html
|
|
getRepoDevNewR shr rp = do
|
|
(sid, mjid, rid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
|
return (s, repoProject repository, r)
|
|
((_result, widget), enctype) <-
|
|
runFormPost $ newRepoCollabForm sid mjid rid
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
|
|
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
getRepoDevR shr rp dev = do
|
|
rl <- runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid
|
|
role <- getJust $ repoCollabRole collab
|
|
return $ repoRoleIdent role
|
|
defaultLayout $(widgetFile "repo/collab/one")
|
|
|
|
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
deleteRepoDevR shr rp dev = do
|
|
runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
Entity cid _collab <- getBy404 $ UniqueRepoCollab rid pid
|
|
delete cid
|
|
setMessage "Collaborator removed."
|
|
redirect $ RepoDevsR shr rp
|
|
|
|
postRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
postRepoDevR shr rp dev = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteRepoDevR shr rp dev
|
|
_ -> notFound
|