vervis/src/Vervis/Handler/Repo/Git.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018 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.Git
    ( getGitRepoSource
    , getGitRepoHeadChanges
    , getGitRepoChanges
    , getGitPatch
    )
where

import Prelude

import Control.Monad.IO.Class (liftIO)
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.Maybe (fromMaybe)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Traversable (for)
import Database.Esqueleto
import Data.Hourglass (timeConvert)
import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent)
import Text.Blaze.Html (Html)
import Yesod.Core (defaultLayout)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Handler (selectRep, provideRep, notFound)
import Yesod.Persist.Core (runDB, get404)
import Yesod.AtomFeed (atomFeed)
import Yesod.RssFeed (rssFeed)

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.ChangeFeed (changeFeed)
import Vervis.Form.Repo
import Vervis.Foundation
import Vervis.Path
import Vervis.MediaType (chooseMediaType)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo
import Vervis.Paginate
import Vervis.Patch
import Vervis.Readme
import Vervis.Render
import Vervis.Settings
import Vervis.SourceTree
import Vervis.Style
import Vervis.Time (showDate)
import Vervis.Widget.Repo
import Vervis.Widget.Sharer (personLinkW)

import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Git.Local as G (createRepo)
import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs, readPatch)

getGitRepoSource :: Repo -> ShrIdent -> RpIdent -> 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 $(widgetFile "repo/source-git")

getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent
getGitRepoHeadChanges repository shar repo =
    getGitRepoChanges shar repo $ repoMainBranch repository

getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
getGitRepoChanges shar repo ref = do
    path <- askRepoDir shar repo
    (branches, tags) <- liftIO $ G.listRefs path
    if ref `S.member` branches || ref `S.member` tags
        then do
            (entries, navModel) <- getPageAndNav $
                \ o l -> liftIO $ G.readChangesView path ref o l
            let refSelect = refSelectW shar repo branches tags
                changes = changesW shar repo entries
                pageNav = navWidget navModel
                feed = changeFeed shar repo (Just ref) VCSGit entries
            selectRep $ do
                provideRep $ defaultLayout $(widgetFile "repo/changes-git")
                provideRep $ atomFeed feed
                provideRep $ rssFeed feed
        else notFound

getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler Html
getGitPatch shr rp ref = do
    path <- askRepoDir shr rp
    (patch, parents) <- liftIO $ G.readPatch path ref
    msharer <- runDB $ do
        mp <- getBy $ UniquePersonEmail $ patchAuthorEmail patch
        for mp $ \ (Entity _ person) -> get404 $ personIdent person
    defaultLayout $(widgetFile "repo/patch")