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
    , getRepoCommitsR
    )
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.Git (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.Style

import qualified Darcs.Local as D (createRepo)
import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Git.Local as G (createRepo)

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")

instance ResultList D.DList where
    emptyList = D.empty
    appendItem = flip D.snoc

getRepoR :: Text -> Text -> Handler Html
getRepoR user repo = do
    repository <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharerIdent user
        Entity _rid r <- getBy404 $ UniqueRepo repo sid
        return r
    getRepoSource repository user repo (repoMainBranch repository) []

data SourceView a
    = DirectoryView (Maybe Text) TreeRows (Maybe (Text, a))
    | FileView Text a

loadSourceView
    :: Git
    -> Text
    -> [Text]
    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
loadSourceView git refT dir = do
    branches <- branchList git
    tags <- tagList git
    let refS = unpack refT
        refN = RefName refS
    msv <- if refN `S.member` branches || refN `S.member` tags
        then do
            tipOid <- resolveName git refS
            mtree <- resolveTreeish git $ unObjId tipOid
            case mtree of
                Nothing   -> return Nothing
                Just tree -> do
                    let dir' = map (entName . encodeUtf8) dir
                    view <- viewPath git tree dir'
                    Just <$> case view of
                        RootView rows -> do
                            mreadme <- findReadme git rows
                            return $ DirectoryView Nothing rows mreadme
                        TreeView name _ rows -> do
                            mreadme <- findReadme git rows
                            return $ DirectoryView (Just name) rows mreadme
                        BlobView name _ body -> return $ FileView name body
        else return Nothing
    return (branches, tags, msv)

renderSources :: [Text] -> SourceView BL.ByteString -> SourceView Widget
renderSources dir (DirectoryView mname rows mreadme) =
    case mreadme of
        Nothing -> DirectoryView mname rows Nothing
        Just (name, body) ->
            DirectoryView mname rows $ Just (name, renderReadme dir name body)
renderSources dir (FileView name body) =
    let parent = init dir
        (base, ext) = breakExt name
        mediaType = chooseMediaType parent base ext () ()
    in  FileView name $ renderSourceBL mediaType body

getRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
getRepoSource repository user repo ref dir = do
    path <- askRepoDir user repo
    let toText = decodeUtf8With lenientDecode
        toTextL = L.decodeUtf8With lenientDecode
    (branches, tags, msv) <- liftIO $ withRepo (fromString path) $ \ git ->
        loadSourceView git ref dir
    case renderSources dir <$> 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")

getRepoSourceR :: Text -> Text -> Text -> [Text] -> Handler Html
getRepoSourceR user repo ref dir = do
    repository <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharerIdent user
        Entity _rid r <- getBy404 $ UniqueRepo repo sid
        return r
    getRepoSource repository user repo ref dir

getRepoCommitsR :: Text -> Text -> Handler Html
getRepoCommitsR user repo = do
    repository <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharerIdent user
        Entity _rid r <- getBy404 $ UniqueRepo repo sid
        return r
    path <- askRepoDir user repo
    pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
        oid <- resolveName git $ unpack $ repoMainBranch repository
        graph <- loadCommitGraphPT git [oid]
        let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
            nodes = case mnodes of
                Nothing -> error "commit graph contains a cycle"
                Just ns -> ns
        return $ D.toList $ fmap (nodeLabel graph) nodes
    now <- liftIO dateCurrent
    let toText = decodeUtf8With lenientDecode
        mkrow oid commit =
            ( toText $ personName $ commitAuthor commit
            , toText $ toHex $ unObjId oid
            , toText $ takeLine $ commitMessage commit
            , timeAgo' now (timeConvert $ personTime $ commitAuthor commit)
            )
        rows = map (uncurry mkrow) pairs
    defaultLayout $ do
        setTitle $ toHtml $ intercalate " > "
            ["Vervis", "People", user, "Repos", repo, "Commits"]
        $(widgetFile "repo/commits")