vervis/src/Vervis/Handler/Repo.hs

{- 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
    , 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 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 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 = 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 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 = 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
    (pid, rid) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity p _ <- getBy404 $ UniquePersonIdent s
        Entity r _ <- getBy404 $ UniqueRepo rp s
        return (p, r)
    ((result, widget), enctype) <- runFormPost $ newRepoCollabForm pid 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
    (pid, rid) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity p _ <- getBy404 $ UniquePersonIdent s
        Entity r _ <- getBy404 $ UniqueRepo rp s
        return (p, r)
    ((_result, widget), enctype) <- runFormPost $ newRepoCollabForm pid 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