Per-workflow custom ticket field enum types

src/Vervis/Field/Workflow.hs

@@ -16,6 +16,7 @@
 module Vervis.Field.Workflow
     ( newWorkflowIdentField
     , newFieldIdentField
+    , newEnumIdentField
     )
 where
 
@@ -76,3 +77,22 @@ fieldIdentField = convertField text2fld fld2text $ checkTemplate textField
 
 newFieldIdentField :: WorkflowId -> Field Handler FldIdent
 newFieldIdentField wid = checkFldUniqueCI wid fieldIdentField
+
+checkEnmUniqueCI
+    :: WorkflowId -> Field Handler EnmIdent -> Field Handler EnmIdent
+checkEnmUniqueCI wid = checkM $ \ enm -> do
+    sames <- runDB $ select $ from $ \ enum -> do
+        where_ $
+            enum ^. WorkflowFieldEnumWorkflow ==. val wid &&.
+            lower_ (enum ^. WorkflowFieldEnumIdent) ==. lower_ (val enm)
+        limit 1
+        return ()
+    return $ if null sames
+        then Right enm
+        else Left ("There is already an enum by that name" :: Text)
+
+enumIdentField :: Field Handler EnmIdent
+enumIdentField = convertField text2enm enm2text $ checkTemplate textField
+
+newEnumIdentField :: WorkflowId -> Field Handler EnmIdent
+newEnumIdentField wid = checkEnmUniqueCI wid enumIdentField

src/Vervis/Form/Workflow.hs

@@ -18,6 +18,8 @@ module Vervis.Form.Workflow
     , newWorkflowForm
     , NewField (..)
     , newFieldForm
+    , NewEnum (..)
+    , newEnumForm
     )
 where
 
@@ -63,3 +65,18 @@ newFieldAForm wid = NewField
 
 newFieldForm :: WorkflowId -> Form NewField
 newFieldForm wid = renderDivs $ newFieldAForm wid
+
+data NewEnum = NewEnum
+    { neIdent :: EnmIdent
+    , neName  :: Text
+    , neDesc  :: Maybe Text
+    }
+
+newEnumAForm :: WorkflowId -> AForm Handler NewEnum
+newEnumAForm wid = NewEnum
+    <$> areq (newEnumIdentField wid) "Identifier*" Nothing
+    <*> areq textField               "Name*"       Nothing
+    <*> aopt textField               "Description" Nothing
+
+newEnumForm :: WorkflowId -> Form NewEnum
+newEnumForm wid = renderDivs $ newEnumAForm wid

src/Vervis/Foundation.hs

@@ -171,6 +171,9 @@ instance Yesod App where
         (WorkflowFieldsR shr _     , _   ) -> personOrGroupAdmin shr
         (WorkflowFieldNewR shr _   , _   ) -> personOrGroupAdmin shr
         (WorkflowFieldR shr _ _    , _   ) -> personOrGroupAdmin shr
+        (WorkflowEnumsR shr _      , _   ) -> personOrGroupAdmin shr
+        (WorkflowEnumNewR shr _    , _   ) -> personOrGroupAdmin shr
+        (WorkflowEnumR shr _ _     , _   ) -> personOrGroupAdmin shr
 
         (TicketsR shar _           , True) -> person shar
         (TicketNewR _ _            , _   ) -> personAny
@@ -480,6 +483,15 @@ instance YesodBreadcrumbs App where
         WorkflowFieldR shr wfl fld       -> ( fld2text fld
                                             , Just $ WorkflowFieldsR shr wfl
                                             )
+        WorkflowEnumsR shr wfl           -> ( "Enums"
+                                            , Just $ WorkflowR shr wfl
+                                            )
+        WorkflowEnumNewR shr wfl         -> ( "New"
+                                            , Just $ WorkflowEnumsR shr wfl
+                                            )
+        WorkflowEnumR shr wfl fld        -> ( enm2text fld
+                                            , Just $ WorkflowEnumsR shr wfl
+                                            )
 
         TicketsR shar proj               -> ( "Tickets"
                                             , Just $ ProjectR shar proj

src/Vervis/Handler/Workflow.hs

@@ -14,18 +14,27 @@
  -}
 
 module Vervis.Handler.Workflow
-    ( getWorkflowsR
+    ( -- * Workflow
+      getWorkflowsR
     , postWorkflowsR
     , getWorkflowNewR
     , getWorkflowR
     , deleteWorkflowR
     , postWorkflowR
+      -- * Field
     , getWorkflowFieldsR
     , postWorkflowFieldsR
     , getWorkflowFieldNewR
     , getWorkflowFieldR
     , deleteWorkflowFieldR
     , postWorkflowFieldR
+      -- * Enum
+    , getWorkflowEnumsR
+    , postWorkflowEnumsR
+    , getWorkflowEnumNewR
+    , getWorkflowEnumR
+    , deleteWorkflowEnumR
+    , postWorkflowEnumR
     )
 where
 
@@ -49,6 +58,10 @@ import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Widget.Sharer
 
+-------------------------------------------------------------------------------
+-- Workflow
+-------------------------------------------------------------------------------
+
 getWorkflowsR :: ShrIdent -> Handler Html
 getWorkflowsR shr = do
     ws <- runDB $ do
@@ -102,6 +115,10 @@ postWorkflowR shr wfl = do
         Just "DELETE" -> deleteWorkflowR shr wfl
         _             -> notFound
 
+-------------------------------------------------------------------------------
+-- Field
+-------------------------------------------------------------------------------
+
 getWorkflowFieldsR :: ShrIdent -> WflIdent -> Handler Html
 getWorkflowFieldsR shr wfl = do
     fs <- runDB $ do
@@ -164,3 +181,69 @@ postWorkflowFieldR shr wfl fld = do
     case mmethod of
         Just "DELETE" -> deleteWorkflowFieldR shr wfl fld
         _             -> notFound
+
+-------------------------------------------------------------------------------
+-- Enum
+-------------------------------------------------------------------------------
+
+getWorkflowEnumsR :: ShrIdent -> WflIdent -> Handler Html
+getWorkflowEnumsR shr wfl = do
+    es <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
+        selectList [WorkflowFieldEnumWorkflow ==. wid] []
+    defaultLayout $(widgetFile "workflow/enum/list")
+
+postWorkflowEnumsR :: ShrIdent -> WflIdent -> Handler Html
+postWorkflowEnumsR shr wfl = do
+    wid <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
+        return wid
+    ((result, widget), enctype) <- runFormPost $ newEnumForm wid
+    case result of
+        FormSuccess ne -> do
+            let enum = WorkflowFieldEnum
+                    { workflowFieldEnumWorkflow = wid
+                    , workflowFieldEnumIdent    = neIdent ne
+                    , workflowFieldEnumName     = neName ne
+                    , workflowFieldEnumDesc     = neDesc ne
+                    }
+            runDB $ insert_ enum
+            setMessage "Workflow field enum added."
+            redirect $ WorkflowEnumR shr wfl (neIdent ne)
+        FormMissing -> do
+            setMessage "Field(s) missing"
+            defaultLayout $(widgetFile "workflow/enum/new")
+        FormFailure _l -> do
+            setMessage "Workflow field enum creation failed, see below"
+            defaultLayout $(widgetFile "workflow/enum/new")
+
+getWorkflowEnumNewR :: ShrIdent -> WflIdent -> Handler Html
+getWorkflowEnumNewR shr wfl = do
+    wid <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
+        return wid
+    ((_result, widget), enctype) <- runFormPost $ newEnumForm wid
+    defaultLayout $(widgetFile "workflow/enum/new")
+
+getWorkflowEnumR :: ShrIdent -> WflIdent -> EnmIdent -> Handler Html
+getWorkflowEnumR shr wfl enm = do
+    e <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
+        Entity _ e <- getBy404 $ UniqueWorkflowFieldEnum wid enm
+        return e
+    defaultLayout $(widgetFile "workflow/enum/one")
+
+deleteWorkflowEnumR :: ShrIdent -> WflIdent -> EnmIdent -> Handler Html
+deleteWorkflowEnumR shr wfl enm =
+    error "Not implemented, not sure whether to allow it"
+
+postWorkflowEnumR :: ShrIdent -> WflIdent -> EnmIdent -> Handler Html
+postWorkflowEnumR shr wfl enm = do
+    mmethod <- lookupPostParam "_method"
+    case mmethod of
+        Just "DELETE" -> deleteWorkflowEnumR shr wfl enm
+        _             -> notFound

src/Vervis/Model/Ident.hs

@@ -37,6 +37,9 @@ module Vervis.Model.Ident
     , FldIdent (..)
     , fld2text
     , text2fld
+    , EnmIdent (..)
+    , enm2text
+    , text2enm
     )
 where
 
@@ -125,3 +128,13 @@ fld2text = CI.original . unFldIdent
 
 text2fld :: Text -> FldIdent
 text2fld = FldIdent . CI.mk
+
+newtype EnmIdent = EnmIdent { unEnmIdent :: CI Text }
+    deriving
+        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+
+enm2text :: EnmIdent -> Text
+enm2text = CI.original . unEnmIdent
+
+text2enm :: Text -> EnmIdent
+text2enm = EnmIdent . CI.mk