{- This file is part of Vervis. - - Written in 2016 by fr33domlover . - - ♡ 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 - . -} module Vervis.Handler.Repo ( getReposR , postReposR , getRepoNewR , getRepoR , deleteRepoR , postRepoR , 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 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 (requireAuth) 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 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 pid person <- requireAuth Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user ((result, widget), enctype) <- runFormPost $ newRepoForm pid 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 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 = Collab { collabRepo = rid , collabPerson = pid , collabRole = 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 pid person <- requireAuth Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user ((_result, widget), enctype) <- runFormPost $ newRepoForm pid 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) [] 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 "DELETE" -> deleteRepoR shar repo _ -> notFound 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 = error "Not implemented" postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html postRepoDevsR shr rp = error "Not implemented" getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html getRepoDevNewR shr rp = error "Not implemented" getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html getRepoDevR shr rp dev = error "Not implemented" 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 $ UniqueCollab 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