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
    )
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
-- [ ] make repo view that shows a table of commits

import Data.Git.Repository (initRepo)
import Database.Esqueleto
import System.Directory (createDirectoryIfMissing)
--import System.FilePath ((</>))
import Vervis.Import hiding ((==.))
import Vervis.Form.Repo

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 "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
            root <- appRepoDir . appSettings <$> getYesod
            let parent = root </> unpack user </> unpack proj
                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-new")
        FormFailure l -> do
            setMessage $ toHtml $ intercalate "; " l
            defaultLayout $(widgetFile "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-new")

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
    defaultLayout $ do
        setTitle $ toHtml $ intercalate " > " $
            ["Vervis", "People", user, "Projects", proj, "Repos", repo]
        $(widgetFile "repo")