diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index a323440..5e4e24f 100644 --- a/src/Vervis/Client.hs +++ b/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) diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index f72c23b..71a4ed8 100644 --- a/src/Vervis/Form/Project.hs +++ b/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 +-} diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 6742d85..8d9b629 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -348,6 +348,7 @@ instance Yesod App where -- Deck (DeckInboxR _ , False) -> personAny + (DeckNewR , _ ) -> personAny -- Loom diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 8fcb880..ac4721e 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/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" diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index aa63507..b629791 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -19,5 +19,8 @@ $# .