vervis/src/Vervis/Handler/Repo.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019 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"
                        , repoCollabUser = Nothing
                        , repoCollabAnon = Nothing
                        }
                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 (sid, er)
    case mer of
        Nothing -> do
            setMessage "Repo used as a wiki, can't move between projects."
            redirect $ RepoR shr rp
        Just (sid, er@(Entity rid _)) -> do
            ((result, widget), enctype) <- runFormPost $ editRepoForm sid 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
    (sid, er) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        er <- getBy404 $ UniqueRepo rp sid
        return (sid, er)
    ((_result, widget), enctype) <- runFormPost $ editRepoForm sid 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 -> 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 `InnerJoin`
                           person `InnerJoin`
                           sharer `LeftOuterJoin`
                           role) -> do
            on $ collab ^. RepoCollabRole     ==. role ?. ProjectRoleId
            on $ person ^. PersonIdent        ==. sharer ^. SharerId
            on $ collab ^. RepoCollabPerson   ==. person ^. PersonId
            where_ $ collab ^. RepoCollabRepo ==. val rid
            return (sharer, role ?. ProjectRoleIdent)
    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
    mrl <- 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
        fmap projectRoleIdent <$> traverse getJust (repoCollabRole collab)
    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