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
    , getWorkflowFieldsR
    , postWorkflowFieldsR
    , getWorkflowFieldNewR
    , getWorkflowFieldR
    , deleteWorkflowFieldR
    , postWorkflowFieldR
    )
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

getWorkflowFieldsR :: ShrIdent -> WflIdent -> Handler Html
getWorkflowFieldsR shr wfl = do
    fs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
        selectList [WorkflowFieldWorkflow ==. wid] []
    defaultLayout $(widgetFile "workflow/field/list")

postWorkflowFieldsR :: ShrIdent -> WflIdent -> Handler Html
postWorkflowFieldsR shr wfl = do
    wid <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
        return wid
    ((result, widget), enctype) <- runFormPost $ newFieldForm wid
    case result of
        FormSuccess nf -> do
            let field = WorkflowField
                    { workflowFieldWorkflow = wid
                    , workflowFieldIdent    = nfIdent nf
                    , workflowFieldName     = nfName nf
                    , workflowFieldDesc     = nfDesc nf
                    , workflowFieldType     = nfType nf
                    }
            runDB $ insert_ field
            setMessage "Workflow field added."
            redirect $ WorkflowFieldR shr wfl (nfIdent nf)
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "workflow/field/new")
        FormFailure _l -> do
            setMessage "Workflow field creation failed, see below"
            defaultLayout $(widgetFile "workflow/field/new")

getWorkflowFieldNewR :: ShrIdent -> WflIdent -> Handler Html
getWorkflowFieldNewR shr wfl = do
    wid <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
        return wid
    ((_result, widget), enctype) <- runFormPost $ newFieldForm wid
    defaultLayout $(widgetFile "workflow/field/new")

getWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html
getWorkflowFieldR shr wfl fld = do
    f <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
        Entity _ f <- getBy404 $ UniqueWorkflowField wid fld
        return f
    defaultLayout $(widgetFile "workflow/field/one")

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

postWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html
postWorkflowFieldR shr wfl fld = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "DELETE" -> deleteWorkflowFieldR shr wfl fld
        _             -> notFound