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