{- 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
, putRepoR
, deleteRepoR
, postRepoR
, getRepoEditR
, getRepoSourceR
, getRepoHeadChangesR
, getRepoChangesR
, 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.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.Darcs as D (readSourceView, readChangesView)
import qualified Vervis.Formatting as F
import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs)
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 Html
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 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
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