Add repo pages and repo creation form

_boring

@@ -121,3 +121,6 @@
 ^static/combined(/|$)
 ^config/client_session_key.aes$
 ^yesod-devel(/|$)
+
+### vervis
+^repos(/|$)

config/models

@@ -47,6 +47,7 @@ Project
 Repo
     ident   Text       --CI
     project ProjectId
+    desc    Text         Maybe
     irc     IrcChannelId Maybe
     ml      Text         Maybe
 

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

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

src/Data/List/Local.hs

@@ -0,0 +1,30 @@
+{- 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 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

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

src/Vervis/Field/Repo.hs

@@ -0,0 +1,59 @@
+{- 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.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

src/Vervis/Form/Repo.hs

@@ -0,0 +1,33 @@
+{- 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.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

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

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-}

src/Vervis/Handler/Repo.hs

@@ -0,0 +1,98 @@
+{- 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")

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 {..}

templates/repo-new.hamlet

@@ -0,0 +1,21 @@
+$# 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/>.
+
+<h1>Vervis > People > #{user} > Projects > #{proj} > New Repo
+
+Enter your details and click "Submit" to create a new repo.
+
+<form method=POST action=@{ReposR user proj} enctype=#{enctype}>
+  ^{widget}
+  <input type=submit>

templates/repo.hamlet

@@ -0,0 +1,30 @@
+$# 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/>.
+
+<h1>Vervis > People > #{user} > Projects > #{proj} > Repos > #{repo}
+
+<h2>About
+<p>
+  This is the repo page for <b>#{repo}</b>, which is part of project
+  <b>#{proj}</b>, shared by user <b>#{user}</b>.
+
+<h2>Details
+<table>
+  <tr>
+    <td>Description
+    <td>
+      $maybe desc <- repoDesc repository
+        #{desc}
+      $nothing
+        (none)

templates/repos.hamlet

@@ -0,0 +1,24 @@
+$# 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/>.
+
+<h1>Vervis > People > #{user} > Projects > #{proj} > Repos
+
+<p>These are the repositories of project #{proj} shared by #{user}.
+
+<ul>
+  $forall Value repo <- repos
+    <li>
+      <a href=@{RepoR user proj repo}>#{repo}
+  <li>
+    <a href=@{RepoNewR user proj}>Create new...

vervis.cabal

@@ -35,11 +35,14 @@ flag library-only
 
 library
   exposed-modules:     Data.Char.Local
+                       Data.List.Local
                        Vervis.Application
                        Vervis.Field.Person
                        Vervis.Field.Project
+                       Vervis.Field.Repo
                        Vervis.Form.Person
                        Vervis.Form.Project
+                       Vervis.Form.Repo
                        Vervis.Foundation
                        Vervis.Git
                        Vervis.Import
@@ -51,6 +54,7 @@ library
                        Vervis.Handler.Home
                        Vervis.Handler.Person
                        Vervis.Handler.Project
+                       Vervis.Handler.Repo
                        Vervis.Handler.Util
                        Vervis.Style
   -- other-modules:       
@@ -94,6 +98,7 @@ library
                      , esqueleto
                      , fast-logger                   >= 2.2        && < 2.5
                      , file-embed
+                     , filepath
                      , hit
                      , hjsmin                        >= 0.1        && < 0.2
                      , hourglass