vervis/src/Vervis/Handler/Workflow.hs

{- 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.Workflow
    ( getWorkflowsR
    , postWorkflowsR
    , getWorkflowNewR
    , getWorkflowR
    , deleteWorkflowR
    , postWorkflowR
    )
where

import Prelude

import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Database.Persist
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404)

import Vervis.Form.Workflow
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Widget.Sharer

getWorkflowsR :: ShrIdent -> Handler Html
getWorkflowsR shr = do
    ws <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        selectList [WorkflowSharer ==. sid] []
    defaultLayout $(widgetFile "workflow/list")

postWorkflowsR :: ShrIdent -> Handler Html
postWorkflowsR shr = do
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((result, widget), enctype) <- runFormPost $ newWorkflowForm sid
    case result of
        FormSuccess nw -> do
            let workflow = Workflow
                    { workflowSharer = sid
                    , workflowIdent  = nwIdent nw
                    , workflowName   = nwName nw
                    , workflowDesc   = nwDesc nw
                    }
            runDB $ insert_ workflow
            setMessage "Workflow added."
            redirect $ WorkflowR shr (nwIdent nw)
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "workflow/new")
        FormFailure _l -> do
            setMessage "Workflow creation failed, see below"
            defaultLayout $(widgetFile "workflow/new")

getWorkflowNewR :: ShrIdent -> Handler Html
getWorkflowNewR shr = do
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((_result, widget), enctype) <- runFormPost $ newWorkflowForm sid
    defaultLayout $(widgetFile "workflow/new")

getWorkflowR :: ShrIdent -> WflIdent -> Handler Html
getWorkflowR shr wfl = do
    w <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharer shr
        Entity _wid w <- getBy404 $ UniqueWorkflow sid wfl
        return w
    defaultLayout $(widgetFile "workflow/one")

deleteWorkflowR :: ShrIdent -> WflIdent -> Handler Html
deleteWorkflowR shr wfl = error "Not implemented, not sure whether to allow it"

postWorkflowR :: ShrIdent -> WflIdent -> Handler Html
postWorkflowR shr wfl = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "DELETE" -> deleteWorkflowR shr wfl
        _             -> notFound