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 (unpack)
import Yesod                       hiding (Header, parseTime, (==.))
import Yesod.Auth

import Data.Byteable (toBytes)
import Data.Git.Graph
import Data.Git.Graph.Util
import Data.Git.Named (RefName (..))
import Data.Git.Ref (toHex)
import Data.Git.Repository
import Data.Git.Storage (withRepo, getObject_)
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.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 Vervis.Form.Repo
import Vervis.Foundation
import Vervis.Git (timeAgo')
import Vervis.Path
import Vervis.Model
import Vervis.Settings

getReposR :: Text -> Text -> Handler Html
getReposR user proj = do
    repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
        where_ $
            sharer ^. SharerIdent ==. val user &&.
            sharer ^. SharerId ==. project ^. ProjectSharer &&.
            repo ^. RepoProject ==. project ^. ProjectId
        orderBy [asc $ repo ^. RepoIdent]
        return $ repo ^. RepoIdent
    defaultLayout $ do
        setTitle $ toHtml $ mconcat
            ["Vervis > People > ", user, " > Projects > ", proj, " Repos"]
        $(widgetFile "repo/repos")

postReposR :: Text -> Text -> Handler Html
postReposR user proj = do
    Entity _pid person <- requireAuth
    let sid = personIdent person
    Entity pid _project <- runDB $ getBy404 $ UniqueProject proj sid
    ((result, widget), enctype) <- runFormPost $ newRepoForm sid pid
    case result of
        FormSuccess repo -> do
            parent <- askProjectDir user proj
            let path = parent </> unpack (repoIdent repo)
            liftIO $ createDirectoryIfMissing True parent
            liftIO $ initRepo $ fromString path
            runDB $ insert_ repo
            setMessage "Repo added."
            redirectUltDest HomeR
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "repo/repo-new")
        FormFailure l -> do
            setMessage $ toHtml $ intercalate "; " l
            defaultLayout $(widgetFile "repo/repo-new")

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

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

getRepoR :: Text -> Text -> Text -> Handler Html
getRepoR user proj repo = do
    repository <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharerIdent user
        Entity pid _p <- getBy404 $ UniqueProject proj sid
        Entity _rid r <- getBy404 $ UniqueRepo repo pid
        return r
    path <- askRepoDir user proj repo
    view <- liftIO $ withRepo (fromString path) $ \ git -> do
        oid <- resolveName git $ unpack $ repoMainBranch repository
        commit <- getCommit git $ unObjId oid
        tree <- getTree git $ commitTreeish commit
        viewTree git tree
    let toText = decodeUtf8With lenientDecode
        mkrow (_perm, name, isTree) =
            ( if isTree then "[D]" else "[F]" :: Text
            , toText $ toBytes name
            )
        rows = map mkrow view
    defaultLayout $ do
        setTitle $ toHtml $ intercalate " > " $
            ["Vervis", "People", user, "Projects", proj, "Repos", repo]
        $(widgetFile "repo/repo")

getRepoSourceR :: Text -> Text -> Text -> Text -> [Text] -> Handler Html
getRepoSourceR user proj repo ref dir = do
    path <- askRepoDir user proj repo
    let toText = decodeUtf8With lenientDecode
        toTextL = L.decodeUtf8With lenientDecode
    minfo <- liftIO $ withRepo (fromString path) $ \ git -> do
        branches <- branchList git
        tags <- tagList git
        let name = unpack ref
            name' = RefName name
        if name' `S.member` branches || name' `S.member` tags
            then do
                tipOid <- resolveName git name
                mtree <- resolveTreeish git $ unObjId tipOid
                case mtree of
                    Nothing   -> return Nothing
                    Just tree -> do
                        let dir' = map (entName . encodeUtf8) dir
                        mRootOid <- resolveTreePath git tree dir'
                        target <- case mRootOid of
                            Nothing  -> return $ Right tree
                            Just oid -> do
                                obj <- getObject_ git (unObjId oid) True
                                case obj of
                                    ObjTree t -> return $ Right t
                                    ObjBlob b -> return $ Left b
                                    _         -> error "expected tree or blob"
                        view <- case target of
                            Left b  -> Left  <$> return b
                            Right t -> Right <$> viewTree git t
                        return $ Just (branches, tags, view)
            else return Nothing
    case minfo of
        Nothing                     -> notFound
        Just (branches, tags, view) -> do
            let mkrow (_perm, name, isTree) =
                    ( if isTree then "[D]" else "[F]" :: Text
                    , toText $ toBytes name
                    )
                display = case view of
                    Left b  -> Left $ toTextL $ blobGetContent b
                    Right v -> Right $ map mkrow v
            defaultLayout $ do
                setTitle $ toHtml $ intercalate " > " $
                    ["Vervis", "People", user, "Projects", proj, "Repos", repo]
                $(widgetFile "repo/source")

getRepoCommitsR :: Text -> Text -> Text -> Handler Html
getRepoCommitsR user proj repo = do
    repository <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharerIdent user
        Entity pid _p <- getBy404 $ UniqueProject proj sid
        Entity _rid r <- getBy404 $ UniqueRepo repo pid
        return r
    path <- askRepoDir user proj 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, "Projects", proj, "Repos", repo, "Commits"]
        $(widgetFile "repo/commits")