Add repo pages and repo creation form

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