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
    , getRepoSourceR
    , getRepoHeadChangesR
    , getRepoChangesR
    )
where

--TODO CONTINUE HERE
--
-- [/] maybe list project repos in personal overview too
-- [x] make repo list page
-- [x] add new repo creation link
-- [x] make new repo form
-- [x] write the git and mkdir parts that actually create the repo
-- [x] make repo view that shows a table of commits

import ClassyPrelude.Conduit       hiding (last, unpack)
import Yesod                       hiding (Header, parseTime, (==.))
import Yesod.Auth

import Prelude (init, last, tail)

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 (unpack)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Database.Esqueleto
import Data.Hourglass (timeConvert)
import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent)

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.GitOld (timeAgo')
import Vervis.Path
import Vervis.MediaType (chooseMediaType)
import Vervis.Model
import Vervis.Model.Repo
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.Git as G (readSourceView, readChangesView)

getReposR :: Text -> 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 $ do
        setTitle $ toHtml $ intercalate " > "
            ["Vervis", "People", user, "Repos"]
        $(widgetFile "repo/repos")

postReposR :: Text -> Handler Html
postReposR user = do
    Entity _pid person <- requireAuth
    let sid = personIdent person
    ((result, widget), enctype) <- runFormPost $ newRepoForm sid
    case result of
        FormSuccess repo -> do
            parent <- askSharerDir user
            liftIO $ do
                createDirectoryIfMissing True parent
                let repoName = unpack $ 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/repo-new")
        FormFailure _l -> do
            setMessage "Repo creation failed, see errors below"
            defaultLayout $(widgetFile "repo/repo-new")

getRepoNewR :: Text -> Handler Html
getRepoNewR user = do
    Entity _pid person <- requireAuth
    let sid = personIdent person
    ((_result, widget), enctype) <- runFormPost $ newRepoForm sid
    defaultLayout $ do
        setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
        $(widgetFile "repo/repo-new")

selectRepo :: Text -> Text -> AppDB Repo
selectRepo shar repo = do
    Entity sid _s <- getBy404 $ UniqueSharerIdent shar
    Entity _rid r <- getBy404 $ UniqueRepo repo sid
    return r

getRepoR :: Text -> Text -> 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) []

getDarcsRepoSource :: Repo -> Text -> Text -> [Text] -> Handler Html
getDarcsRepoSource repository user repo dir = do
    path <- askRepoDir user repo
    msv <- liftIO $ D.readSourceView path dir
    case msv of
        Nothing -> notFound
        Just sv -> do
            let parent = if null dir then [] else init dir
                dirs = zip parent (tail $ inits parent)
            defaultLayout $ do
                setTitle $ toHtml $ intercalate " > "
                    ["Vervis", "People", user, "Repos", repo]
                $(widgetFile "repo/source-darcs")

getGitRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
getGitRepoSource repository user repo ref dir = do
    path <- askRepoDir user repo
    (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
    case msv of
        Nothing -> notFound
        Just sv -> do
            let parent = if null dir then [] else init dir
                dirs = zip parent (tail $ inits parent)
            defaultLayout $ do
                setTitle $ toHtml $ intercalate " > " $
                    ["Vervis", "People", user, "Repos", repo]
                $(widgetFile "repo/source-git")

getRepoSourceR :: Text -> Text -> [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

getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
getDarcsRepoHeadChanges shar repo = do
    path <- askRepoDir shar repo
    mentries <- liftIO $ D.readChangesView path
    case mentries of
        Nothing -> notFound
        Just entries ->
            let changes = changesW entries
            in  defaultLayout $(widgetFile "repo/changes-darcs")

getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html
getGitRepoHeadChanges repository shar repo =
    getGitRepoChanges shar repo $ repoMainBranch repository

getRepoHeadChangesR :: Text -> Text -> Handler Html
getRepoHeadChangesR user repo = do
    repository <- runDB $ selectRepo user repo
    case repoVcs repository of
        VCSDarcs -> getDarcsRepoHeadChanges user repo
        VCSGit -> getGitRepoHeadChanges repository user repo

getDarcsRepoChanges :: Text -> Text -> Text -> Handler Html
getDarcsRepoChanges shar repo tag = notFound

getGitRepoChanges :: Text -> Text -> Text -> Handler Html
getGitRepoChanges shar repo ref = do
    path <- askRepoDir shar repo
    (branches, tags, mentries) <- liftIO $ G.readChangesView path ref
    case mentries of
        Nothing -> notFound
        Just entries ->
            let refSelect = refSelectW shar repo branches tags
                changes = changesW entries
            in  defaultLayout $(widgetFile "repo/changes-git")

getRepoChangesR :: Text -> Text -> 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