Let user choose VCS and fail to create repo if Darcs is chosen

src/Vervis/Form/Repo.hs

@@ -18,6 +18,8 @@ module Vervis.Form.Repo
     )
 where
 
+--import Prelude
+
 import Vervis.Import
 import Vervis.Field.Repo
 import Vervis.Model.Repo
@@ -26,10 +28,16 @@ newRepoAForm :: SharerId -> AForm Handler Repo
 newRepoAForm sid = Repo
     <$> areq (mkIdentField sid) "Identifier*" Nothing
     <*> pure sid
-    <*> pure VCSGit
+    <*> areq (selectFieldList vcsList) "Version control system*" Nothing
     <*> pure Nothing
     <*> aopt textField "Description" Nothing
     <*> pure "master"
+    where
+    vcsList :: [(Text, VersionControlSystem)]
+    vcsList =
+        [ ("Darcs", VCSDarcs)
+        , ("Git"  , VCSGit)
+        ]
 
 newRepoForm :: SharerId -> Form Repo
 newRepoForm = renderDivs . newRepoAForm

src/Vervis/Handler/Repo.hs

@@ -72,6 +72,7 @@ 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
@@ -96,14 +97,17 @@ postReposR user = do
     let sid = personIdent person
     ((result, widget), enctype) <- runFormPost $ newRepoForm sid
     case result of
-        FormSuccess repo -> do
-            parent <- askSharerDir user
-            liftIO $ do
-                createDirectoryIfMissing True parent
-                initRepo parent (unpack $ repoIdent repo)
-            runDB $ insert_ repo
-            setMessage "Repo added."
-            redirectUltDest HomeR
+        FormSuccess repo ->
+            case repoVcs repo of
+                VCSDarcs -> error "Darcs not supported yet"
+                VCSGit   -> do
+                    parent <- askSharerDir user
+                    liftIO $ do
+                        createDirectoryIfMissing True parent
+                        initRepo parent (unpack $ repoIdent repo)
+                    runDB $ insert_ repo
+                    setMessage "Repo added."
+                    redirect $ ReposR user
         FormMissing -> do
             setMessage "Field(s) missing"
             defaultLayout $(widgetFile "repo/repo-new")