Eventually-decentralized project hosting and management platform

[[ 🗃 ^WvWbo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/WvWbo

SSH: darcs clone USERNAME@vervis.peers.community:WvWbo

Tags

TODO

src / Vervis / Web /

Git.hs

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

import Control.Monad
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
import Data.Text (Text, unpack)
import Data.Text.Encoding
import Data.Text.Encoding.Error (lenientDecode)
import Data.Traversable (for)
import Database.Esqueleto
import Data.Hourglass (timeConvert)
import Network.HTTP.Types
import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent)
import Text.Blaze.Html (Html)
import Yesod.Core
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 as T
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)

import Data.MediaType
import Network.FedURI
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import qualified Web.ActivityPub as AP

import Data.ByteString.Char8.Local (takeLine)
import Data.Git.Local
import Data.Paginate.Local
import Data.Patch.Local
import Text.FilePath.Local (breakExt)

import Vervis.ActivityPub
import Vervis.ChangeFeed (changeFeed)
import Vervis.Changes
import Vervis.Foundation
import Vervis.Path
import Vervis.Model
import Vervis.Model.Ident
import Development.PatchMediaType
import Vervis.Paginate
import Vervis.Readme
import Vervis.Settings
import Vervis.SourceTree
import Vervis.Style
import Vervis.Time (showDate)
import Vervis.Web.Repo
import Vervis.Widget
import Vervis.Widget.Person
import Vervis.Widget.Repo

import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Vervis.Git as G

getGitRepoSource
    :: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> [LoomId] -> Handler Html
getGitRepoSource repository actor repo ref dir loomIDs = do
    path <- askRepoDir 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)
            looms <- runDB $ for loomIDs $ \ loomID -> do
                loom <- getJust loomID
                (loomID,) <$> getJust (loomActor loom)
            defaultLayout $ do
                hashLoom <- getEncodeKeyHashid
                host <- asksSite siteInstanceHost
                ms <- lookupGetParam "style"
                style <-
                    case ms of
                        Nothing -> getsYesod $ appHighlightStyle . appSettings
                        Just s -> return s
                addStylesheet $ HighlightStyleR style
                $(widgetFile "repo/source-git")
    where
    followButton =
        followW (RepoFollowR repo) (RepoUnfollowR repo) (actorFollowers actor)

{-
getGitRepoBranch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
getGitRepoBranch shar repo ref = do
    path <- askRepoDir shar repo
    (branches, _tags) <- liftIO $ G.listRefs path
    if ref `S.member` branches
        then do
            encodeRouteLocal <- getEncodeRouteLocal
            let here = RepoBranchR shar repo ref
                branchAP = Branch
                    { branchName = ref
                    , branchRef  = "refs/heads/" <> ref
                    , branchRepo = encodeRouteLocal $ RepoR shar repo
                    }
            provideHtmlAndAP branchAP $ redirectToPrettyJSON here
        else notFound
-}

getGitRepoChanges :: KeyHashid Repo -> Text -> Handler TypedContent
getGitRepoChanges repo ref = do
    path <- askRepoDir repo
    (branches, tags) <- liftIO $ G.listRefs path
    unless (ref `S.member` branches || ref `S.member` tags)
        notFound
    let here = RepoBranchCommitsR repo ref
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    encodeRoutePageLocal <- getEncodeRoutePageLocal
    let pageUrl = encodeRoutePageLocal here
        getChanges o l = liftIO $ G.readChangesView path ref o l
    mpage <- getPageAndNavMaybe getChanges
    case mpage of
        Nothing -> do
            (total, pages, _, _) <- getPageAndNavTop getChanges
            let collection = AP.Collection
                    { AP.collectionId         = encodeRouteLocal here
                    , AP.collectionType       = AP.CollectionTypeOrdered
                    , AP.collectionTotalItems = Just total
                    , AP.collectionCurrent    = Nothing
                    , AP.collectionFirst      = Just $ pageUrl 1
                    , AP.collectionLast       = Just $ pageUrl pages
                    , AP.collectionItems      = [] :: [Text]
                    }
            provideHtmlAndAP collection $ redirectFirstPage here
        Just (_total, pages, items, navModel) ->
            let current = nmCurrent navModel
                page = AP.CollectionPage
                    { AP.collectionPageId         = pageUrl current
                    , AP.collectionPageType       = AP.CollectionPageTypeOrdered
                    , AP.collectionPageTotalItems = Nothing
                    , AP.collectionPageCurrent    = Just $ pageUrl current
                    , AP.collectionPageFirst      = Just $ pageUrl 1
                    , AP.collectionPageLast       = Just $ pageUrl pages
                    , AP.collectionPagePartOf     = encodeRouteLocal here
                    , AP.collectionPagePrev       =
                        if current > 1
                            then Just $ pageUrl $ current - 1
                            else Nothing
                    , AP.collectionPageNext       =
                        if current < pages
                            then Just $ pageUrl $ current + 1
                            else Nothing
                    , AP.collectionPageStartIndex = Nothing
                    , AP.collectionPageItems      =
                        map (encodeRouteHome . RepoCommitR repo . leHash)
                            items
                    }
                feed = changeFeed repo (Just ref) VCSGit items
            in  provideHtmlFeedAndAP page feed $
                    let refSelect = refSelectW repo branches tags
                        changes = changesW repo items
                        pageNav = navWidget navModel
                    in  $(widgetFile "repo/changes-git")

getGitPatch :: KeyHashid Repo -> Text -> Handler TypedContent
getGitPatch hash ref = do
    path <- askRepoDir hash
    (patch, parents) <- liftIO $ G.readPatch path ref
    serveCommit hash ref patch parents
[See repo JSON]