{- This file is part of Vervis. - - Written in 2016 by fr33domlover . - - ♡ 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 - . -} 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")