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
    , 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
    let sid = personIdent person
    ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
    case result of
        FormSuccess repo -> do
            parent <- askSharerDir user
            liftIO $ do
                createDirectoryIfMissing True parent
                let repoName =
                        unpack $ CI.foldedCase $ unRpIdent $ repoIdent repo
                case repoVcs repo of
                    VCSDarcs -> D.createRepo parent repoName
                    VCSGit   -> G.createRepo parent repoName
            runDB $ insert_ repo
            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
    let sid = personIdent person
    ((_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) []

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