Client, UI: Form for creating a new Deck

src/Vervis/Client.hs

@@ -14,22 +14,22 @@
  -}
 
 module Vervis.Client
-    ( createThread
-    , createReply
-    , follow
-    , followSharer
-    , followProject
-    , followTicket
-    , followRepo
-    , offerTicket
-    , resolve
-    , undoFollowSharer
-    , undoFollowProject
-    , undoFollowTicket
-    , undoFollowRepo
-    , unresolve
-    , offerMR
-    , createDeck
+    ( --createThread
+    --, createReply
+    --, follow
+    --, followSharer
+    --, followProject
+    --, followTicket
+    --, followRepo
+    --, offerTicket
+    --, resolve
+    --, undoFollowSharer
+    --, undoFollowProject
+    --, undoFollowTicket
+    --, undoFollowRepo
+    --, unresolve
+    --, offerMR
+      createDeck
     )
 where
 
@@ -70,11 +70,11 @@ import Vervis.ActivityPub
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Model.Ident
 import Vervis.Recipient
 import Vervis.Ticket
 import Vervis.WorkItem
 
+{-
 createThread
     :: (MonadSite m, SiteEnv m ~ App)
     => ShrIdent
@@ -593,20 +593,19 @@ offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do
             }
     return (Nothing, Audience recips [] [] [] [] [], ticket)
     -}
+-}
 
 createDeck
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent
+    => KeyHashid Person
     -> Text
-    -> Maybe Text
-    -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, Maybe FedURI)
-createDeck shrAuthor name mdesc = do
-    error "Temporarily disabled"
-    {-
+    -> Text
+    -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail)
+createDeck senderHash name desc = do
     encodeRouteHome <- getEncodeRouteHome
 
     let audAuthor =
-            AudLocal [] [LocalPersonCollectionSharerFollowers shrAuthor]
+            AudLocal [] [LocalStagePersonFollowers senderHash]
 
         (_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
 
@@ -616,8 +615,7 @@ createDeck shrAuthor name mdesc = do
             { AP.actorType     = AP.ActorTypeTicketTracker
             , AP.actorUsername = Nothing
             , AP.actorName     = Just name
-            , AP.actorSummary  = mdesc
+            , AP.actorSummary  = Just desc
             }
 
-    return (Nothing, Audience recips [] [] [] [] [], detail, Nothing)
-    -}
+    return (Nothing, AP.Audience recips [] [] [] [] [], detail)

src/Vervis/Form/Project.hs

@@ -16,16 +16,15 @@
 module Vervis.Form.Project
     ( NewProject (..)
     , newProjectForm
-    , NewProjectCollab (..)
-    , newProjectCollabForm
-    , editProjectForm
+    --, NewProjectCollab (..)
+    --, newProjectCollabForm
+    --, editProjectForm
     )
 where
 
 import Data.Bifunctor
 import Data.Maybe
 import Data.Text (Text)
-import Database.Esqueleto hiding ((==.))
 import Database.Persist ((==.))
 import Yesod.Form.Fields
 import Yesod.Form.Functions
@@ -34,52 +33,20 @@ import Yesod.Persist.Core
 
 import qualified Database.Esqueleto as E
 
-import Vervis.Field.Project
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Model.Ident
-import Development.PatchMediaType
-import Vervis.Model.Workflow
 
 data NewProject = NewProject
     { npName  :: Text
-    , npDesc  :: Maybe Text
-    , npWflow :: WorkflowId
-    , npRole  :: Maybe RoleId
+    , npDesc  :: Text
     }
 
-newProjectAForm :: SharerId -> AForm Handler NewProject
-newProjectAForm sid = NewProject
-    <$> areq textField                  "Name*"       Nothing
-    <*> aopt textField                  "Description" Nothing
-    <*> areq selectWorkflow             "Workflow*"   Nothing
-    <*> aopt selectRole                 "Custom role" Nothing
-    where
-    selectRole =
-        selectField $
-        optionsPersistKey [RoleSharer ==. sid] [] $
-        rl2text . roleIdent
-    selectWorkflow = selectField $ do
-        l <- runDB $ select $ from $ \ (w `InnerJoin` s) -> do
-            on $ w ^. WorkflowSharer E.==. s ^. SharerId
-            where_ $
-                w ^. WorkflowSharer E.==. val sid      E.||.
-                w ^. WorkflowScope  E.!=. val WSSharer
-            return
-                ( s ^. SharerIdent
-                , w ^. WorkflowId
-                , w ^. WorkflowIdent
-                , w ^. WorkflowName
-                )
-        let mkpair (Value sident, Value wid, Value wident, Value wname) =
-                ( shr2text sident <> " / " <> fromMaybe (wfl2text wident) wname
-                , wid
-                )
-        optionsPairs $ map mkpair l
-
-newProjectForm :: SharerId -> Form NewProject
-newProjectForm sid = renderDivs $ newProjectAForm sid
+newProjectForm :: Form NewProject
+newProjectForm = renderDivs $ NewProject
+    <$> areq textField "Name*"       Nothing
+    <*> areq textField "Description" Nothing
 
+{-
 data NewProjectCollab = NewProjectCollab
     { ncPerson :: PersonId
     , ncRole   :: Maybe RoleId
@@ -134,3 +101,4 @@ editProjectAForm sid (Entity jid project) = Project
 
 editProjectForm :: SharerId -> Entity Project -> Form Project
 editProjectForm s j = renderDivs $ editProjectAForm s j
+-}

src/Vervis/Foundation.hs

@@ -348,6 +348,7 @@ instance Yesod App where
         -- Deck
 
         (DeckInboxR _   , False) -> personAny
+        (DeckNewR       , _    ) -> personAny
 
         -- Loom
 

src/Vervis/Handler/Deck.hs

@@ -93,12 +93,15 @@ import Yesod.Persist.Local
 import Vervis.Actor
 import Vervis.API
 import Vervis.Federation
+import Vervis.Form.Project
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Paginate
 import Vervis.Settings
 import Vervis.Widget.Person
 
+import qualified Vervis.Client as C
+
 getDeckR :: KeyHashid Deck -> Handler TypedContent
 getDeckR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
@@ -251,43 +254,43 @@ getDeckTreeR _ = error "Temporarily disabled"
 
 getDeckNewR :: Handler Html
 getDeckNewR = do
-    error "Temporarily disabled"
-    {-
-    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
-    ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
+    ((_result, widget), enctype) <- runFormPost newProjectForm
     defaultLayout $(widgetFile "project/new")
-    -}
+
+runForm here form = do
+    ((result, widget), enctype) <- runFormPost $ newProjectForm
+    case result of
+        FormMissing -> do
+            setMessage "Field(s) missing"
+            redirect here
+        FormFailure _l -> do
+            setMessage "Operation failed, see below"
+            redirect here
+        FormSuccess v -> return (v, widget, enctype)
 
 postDeckNewR :: Handler Html
 postDeckNewR = do
-    error "Temporarily disabled"
-    {-
-    ep@(Entity _ p) <- requireAuth
-    Entity sid s <- runDB $ do
-        _ <- getBy404 $ UniqueSharer shr
-        getJustEntity $ personIdent p
-    unless (sharerIdent s == shr) $
-        invalidArgs ["Trying to create project under someone/something else"]
-    ((result, widget), enctype) <- runFormPost $ newProjectForm sid
-    eprj <- runExceptT $ do
-        NewProject name mdesc _ _ <-
-            case result of
-                FormSuccess np -> return np
-                FormMissing -> throwE "Field(s) missing"
-                FormFailure _l -> throwE "Project creation failed, see below"
-        (msummary, audience, detail, mtarget) <- lift $ createDeck shr name mdesc
-        obiidCreate <- createTicketTrackerC ep s msummary audience detail mtarget
-        runDBExcept $ do
-            mj <- lift $ getValBy $ UniqueProjectCreate obiidCreate
-            projectIdent <$> fromMaybeE mj "New project not found"
-    case eprj of
+    (NewProject name desc, _widget, _enctype) <- runForm DeckNewR newProjectForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    (maybeSummary, audience, detail) <- C.createDeck personHash name desc
+    actor <- runDB $ getJust $ personActor person
+    result <-
+        runExceptT $ createTicketTrackerC personEntity actor maybeSummary audience detail Nothing Nothing
+
+    case result of
         Left e -> do
             setMessage $ toHtml e
-            defaultLayout $(widgetFile "project/new")
-        Right prj -> do
-            setMessage "Project created!"
-            redirect $ ProjectR shr prj
-    -}
+            redirect DeckNewR
+        Right createID -> do
+            maybeDeckID <- runDB $ getKeyBy $ UniqueDeckCreate createID
+            case maybeDeckID of
+                Nothing -> error "Can't find the newly created deck"
+                Just deckID -> do
+                    deckHash <- encodeKeyHashid deckID
+                    setMessage "New ticket tracker created"
+                    redirect $ DeckR deckHash
 
 postDeckDeleteR :: KeyHashid Deck -> Handler Html
 postDeckDeleteR _ = error "Temporarily disabled"

templates/personal-overview.hamlet

@@ -19,5 +19,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <ul>
   <li>
+  <li>
+    <a href=@{DeckNewR}>
+      Create a new ticket tracker
     <a href=@{PublishR}>
       Publish an activity

templates/project/new.hamlet

@@ -12,11 +12,7 @@ $# 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/>.
 
-<p>
-  NOTE: Your workflow and role choices will be ignored. They're temporarily
-  not in use while these features are being federated.
-
-<form method=POST action=@{ProjectsR shr} enctype=#{enctype}>
+<form method=POST action=@{DeckNewR} enctype=#{enctype}>
   ^{widget}
   <div class="submit">
       <input type="submit">

vervis.cabal

@@ -129,7 +129,7 @@ library
                        Vervis.Changes
                        Vervis.ChangeFeed
                        --Vervis.Class.Actor
-                       --Vervis.Client
+                       Vervis.Client
                        Vervis.Cloth
                        Vervis.Colour
                        Vervis.Content
@@ -155,7 +155,7 @@ library
                        Vervis.Form.Discussion
                        --Vervis.Form.Group
                        -- Vervis.Form.Key
-                       --Vervis.Form.Project
+                       Vervis.Form.Project
                        --Vervis.Form.Repo
                        --Vervis.Form.Role
                        --Vervis.Form.Ticket