From ec4c7de58283bbf8c0edef8ec7874cdf2ac55844 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 27 Feb 2016 05:41:36 +0000 Subject: [PATCH] Add repo pages and repo creation form --- _boring | 3 ++ config/models | 1 + config/routes | 9 +++- config/settings.yml | 1 + src/Data/List/Local.hs | 30 ++++++++++++ src/Vervis/Application.hs | 1 + src/Vervis/Field/Repo.hs | 59 +++++++++++++++++++++++ src/Vervis/Form/Repo.hs | 33 +++++++++++++ src/Vervis/Foundation.hs | 39 ++++++++------- src/Vervis/Git.hs | 14 ++++++ src/Vervis/Handler/Repo.hs | 98 ++++++++++++++++++++++++++++++++++++++ src/Vervis/Settings.hs | 3 ++ templates/repo-new.hamlet | 21 ++++++++ templates/repo.hamlet | 30 ++++++++++++ templates/repos.hamlet | 24 ++++++++++ vervis.cabal | 5 ++ 16 files changed, 352 insertions(+), 19 deletions(-) create mode 100644 src/Data/List/Local.hs create mode 100644 src/Vervis/Field/Repo.hs create mode 100644 src/Vervis/Form/Repo.hs create mode 100644 src/Vervis/Handler/Repo.hs create mode 100644 templates/repo-new.hamlet create mode 100644 templates/repo.hamlet create mode 100644 templates/repos.hamlet diff --git a/_boring b/_boring index fe88099..3119854 100644 --- a/_boring +++ b/_boring @@ -121,3 +121,6 @@ ^static/combined(/|$) ^config/client_session_key.aes$ ^yesod-devel(/|$) + +### vervis +^repos(/|$) diff --git a/config/models b/config/models index 303a8b8..762a730 100644 --- a/config/models +++ b/config/models @@ -47,6 +47,7 @@ Project Repo ident Text --CI project ProjectId + desc Text Maybe irc IrcChannelId Maybe ml Text Maybe diff --git a/config/routes b/config/routes index aa36a6f..f13ad40 100644 --- a/config/routes +++ b/config/routes @@ -40,8 +40,13 @@ /u/#Text/p/!new ProjectNewR GET /u/#Text/p/#Text ProjectR GET --- /u/#Text/p/#Text/r ReposR GET --- /u/#Text/p/#Text/r/#Text RepoR GET +-- IDEA: if there's /u/john/p/proj/r/repo, then make /u/john/r/proj-repo +-- redirect there. consider having a clean way to refer to repos +-- independently of projects... +/u/#Text/p/#Text/r ReposR GET POST +/u/#Text/p/#Text/r/!new RepoNewR GET +/u/#Text/p/#Text/r/#Text RepoR GET + -- /u/#Text/p/#Text/t TicketsR GET -- /u/#Text/p/#Text/t/#TicketId TicketR GET -- /u/#Text/p/#Text/w WikiR GET diff --git a/config/settings.yml b/config/settings.yml index c1342d9..5ca2601 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -38,4 +38,5 @@ database: database: "_env:PGDATABASE:vervis_dev" poolsize: "_env:PGPOOLSIZE:10" +repo-dir: repos copyright: Insert your statement against copyright here diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs new file mode 100644 index 0000000..787b14c --- /dev/null +++ b/src/Data/List/Local.hs @@ -0,0 +1,30 @@ +{- 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 Data.List.Local + ( -- groupByFst + ) +where + +import Prelude + +-- | Takes a list of pairs and groups them by consecutive ranges with equal +-- first element. Returns a list of pairs, where each pair corresponds to one +-- such range. +groupByFst :: Eq a => [(a, b)] -> [(a, [b])] +groupByFst [] = [] +groupByFst ((x, y):ps) = + let (same, rest) = span ((== x) . fst) ps + in (x, y : map snd same) : groupByFst rest diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 0785200..10354cb 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -53,6 +53,7 @@ import Vervis.Handler.Common import Vervis.Handler.Home import Vervis.Handler.Person import Vervis.Handler.Project +import Vervis.Handler.Repo -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/src/Vervis/Field/Repo.hs b/src/Vervis/Field/Repo.hs new file mode 100644 index 0000000..b02bab1 --- /dev/null +++ b/src/Vervis/Field/Repo.hs @@ -0,0 +1,59 @@ +{- 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.Field.Repo + ( mkIdentField + ) +where + +import Vervis.Import hiding ((==.)) + +import Data.Char (isDigit) +import Data.Char.Local (isAsciiLetter) +import Data.Text (split) +import Database.Esqueleto hiding (isNothing) + +checkIdentTemplate :: Field Handler Text -> Field Handler Text +checkIdentTemplate = + let charOk c = isAsciiLetter c || isDigit c + wordOk w = (not . null) w && all charOk w + identOk t = (not . null) t && all wordOk (split (== '-') t) + msg :: Text + msg = "The repo identifier must be a sequence of one or more words \ + \separated by hyphens (‘-’), and each such word may contain \ + \ASCII letters and digits." + in checkBool identOk msg + +-- | Make sure the repo identifier is unique. The DB schema only requires that +-- a repo identifier is unique within its project, but I'd like to enforce a +-- stronger condition: A repo identifier must be unique within its sharer's +-- repos. I'm not yet sure it's a good thing, but it's much easier to maintain +-- now and relax later, than relax now and have problems later when there are +-- already conflicting names. +checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text +checkIdentUnique sid = checkM $ \ ident -> do + l <- runDB $ select $ from $ \ (project, repo) -> do + where_ $ + project ^. ProjectSharer ==. val sid &&. + repo ^. RepoProject ==. project ^. ProjectId &&. + repo ^. RepoIdent ==. val ident + limit 1 + return () + return $ if isNothing $ listToMaybe l + then Right ident + else Left ("You already have a repo by that name" :: Text) + +mkIdentField :: SharerId -> Field Handler Text +mkIdentField sid = checkIdentUnique sid . checkIdentTemplate $ textField diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs new file mode 100644 index 0000000..a08e410 --- /dev/null +++ b/src/Vervis/Form/Repo.hs @@ -0,0 +1,33 @@ +{- 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.Form.Repo + ( newRepoForm + ) +where + +import Vervis.Import +import Vervis.Field.Repo + +newRepoAForm :: SharerId -> ProjectId -> AForm Handler Repo +newRepoAForm sid pid = Repo + <$> areq (mkIdentField sid) "Identifier*" Nothing + <*> pure pid + <*> aopt textField "Description" Nothing + <*> pure Nothing + <*> pure Nothing + +newRepoForm :: SharerId -> ProjectId -> Form Repo +newRepoForm sid pid = renderDivs $ newRepoAForm sid pid diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c36fb8b..2f6f93d 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -105,23 +105,10 @@ instance Yesod App where authRoute _ = Just $ AuthR LoginR -- Who can access which pages. - isAuthorized (ProjectNewR ident) _ = do - mp <- maybeAuth - case mp of - Nothing -> return AuthenticationRequired - Just (Entity _pid person) -> do - let sid = personIdent person - msharer <- runDB $ get sid - case msharer of - Nothing -> return $ Unauthorized $ - "Integrity error: User " <> - personLogin person <> - " specified a nonexistent sharer ID" - Just sharer -> - if ident == sharerIdent sharer - then return Authorized - else return $ Unauthorized - "You can’t create projects for other users" + isAuthorized (ProjectNewR user) _ = + loggedInAs user "You can’t create projects for other users" + isAuthorized (RepoNewR user _proj) _ = + loggedInAs user "You can’t create repos for other users" isAuthorized _ _ = return Authorized -- This function creates static content files in the static folder @@ -223,3 +210,21 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Sending-email -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding + +loggedInAs :: Text -> Text -> Handler AuthResult +loggedInAs ident msg = do + mp <- maybeAuth + case mp of + Nothing -> return AuthenticationRequired + Just (Entity _pid person) -> do + let sid = personIdent person + msharer <- runDB $ get sid + case msharer of + Nothing -> return $ Unauthorized $ + "Integrity error: User " <> + personLogin person <> + " specified a nonexistent sharer ID" + Just sharer -> + if ident == sharerIdent sharer + then return Authorized + else return $ Unauthorized msg diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 009a23a..f350f4f 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -115,3 +115,17 @@ timeAgo dt = do let sec = timeDiff now dt (period, duration) = fromSec sec return $ showAgo period duration + +{-commits' :: Git -> Ref -> Int -> IO [(Text, Text, Text, Text)] +commits' git r l = go r l + where + go _ 0 = return [] + go ref lim = do + commit <- getCommit git ref + +commits :: Git -> String -> Int -> IO [(Text, Text, Text, Text)] +commits git branch lim = do + mref <- resolveRevision git $ Revision branch [] + case mref of + Nothing -> return [] + Just ref -> commits' git ref lim-} diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs new file mode 100644 index 0000000..838aaa8 --- /dev/null +++ b/src/Vervis/Handler/Repo.hs @@ -0,0 +1,98 @@ +{- 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 + ) +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") diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 73fd400..4ee1a2f 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -66,6 +66,8 @@ data AppSettings = AppSettings -- ^ Perform no stylesheet/script combining -- Example app-specific configuration values. + , appRepoDir :: FilePath + -- ^ Path to the directory under which git repos are placed , appCopyright :: Text -- ^ Copyright text to appear in the footer of the page } @@ -91,6 +93,7 @@ instance FromJSON AppSettings where appMutableStatic <- o .:? "mutable-static" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev + appRepoDir <- o .: "repo-dir" appCopyright <- o .: "copyright" return AppSettings {..} diff --git a/templates/repo-new.hamlet b/templates/repo-new.hamlet new file mode 100644 index 0000000..e3a67c3 --- /dev/null +++ b/templates/repo-new.hamlet @@ -0,0 +1,21 @@ +$# 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 +$# . + +

Vervis > People > #{user} > Projects > #{proj} > New Repo + +Enter your details and click "Submit" to create a new repo. + +
+ ^{widget} + diff --git a/templates/repo.hamlet b/templates/repo.hamlet new file mode 100644 index 0000000..5244941 --- /dev/null +++ b/templates/repo.hamlet @@ -0,0 +1,30 @@ +$# 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 +$# . + +

Vervis > People > #{user} > Projects > #{proj} > Repos > #{repo} + +

About +

+ This is the repo page for #{repo}, which is part of project + #{proj}, shared by user #{user}. + +

Details + + +
Description + + $maybe desc <- repoDesc repository + #{desc} + $nothing + (none) diff --git a/templates/repos.hamlet b/templates/repos.hamlet new file mode 100644 index 0000000..c64f098 --- /dev/null +++ b/templates/repos.hamlet @@ -0,0 +1,24 @@ +$# 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 +$# . + +

Vervis > People > #{user} > Projects > #{proj} > Repos + +

These are the repositories of project #{proj} shared by #{user}. + +