mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-30 04:37:51 +09:00
127 lines
4.4 KiB
Haskell
127 lines
4.4 KiB
Haskell
{- This file is part of Vervis.
|
||
-
|
||
- Written in 2016, 2019 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.Field.Workflow
|
||
( newWorkflowIdentField
|
||
, newFieldIdentField
|
||
, newEnumIdentField
|
||
, newCtorNameField
|
||
)
|
||
where
|
||
|
||
import Data.Char (isDigit, isAlphaNum)
|
||
import Data.Char.Local (isAsciiLetter)
|
||
import Data.Text (Text)
|
||
import Database.Esqueleto
|
||
import Yesod.Form.Fields
|
||
import Yesod.Form.Functions
|
||
import Yesod.Form.Types
|
||
import Yesod.Persist.Core
|
||
|
||
import qualified Data.Text as T
|
||
|
||
import Vervis.Foundation
|
||
import Vervis.Model
|
||
import Vervis.Model.Ident
|
||
|
||
checkTemplate :: Field Handler Text -> Field Handler Text
|
||
checkTemplate =
|
||
let charOk c = isAsciiLetter c || isDigit c
|
||
wordOk w = (not . T.null) w && T.all charOk w
|
||
identOk t = (not . T.null) t && all wordOk (T.split (== '-') t)
|
||
msg :: Text
|
||
msg = "The identifier must be a sequence of one or more words \
|
||
\separated by hyphens (‘-’), and each such word may contain \
|
||
\ASCII letters and digits."
|
||
in checkBool identOk msg
|
||
|
||
checkWflUniqueCI
|
||
:: SharerId -> Field Handler WflIdent -> Field Handler WflIdent
|
||
checkWflUniqueCI sid = checkM $ \ wfl -> do
|
||
sames <- runDB $ select $ from $ \ workflow -> do
|
||
where_ $
|
||
workflow ^. WorkflowSharer ==. val sid &&.
|
||
lower_ (workflow ^. WorkflowIdent) ==. lower_ (val wfl)
|
||
limit 1
|
||
return ()
|
||
return $ if null sames
|
||
then Right wfl
|
||
else Left ("You already have a workflow by that name" :: Text)
|
||
|
||
workflowIdentField :: Field Handler WflIdent
|
||
workflowIdentField = convertField text2wfl wfl2text $ checkTemplate textField
|
||
|
||
newWorkflowIdentField :: SharerId -> Field Handler WflIdent
|
||
newWorkflowIdentField sid = checkWflUniqueCI sid workflowIdentField
|
||
|
||
checkFldUniqueCI
|
||
:: WorkflowId -> Field Handler FldIdent -> Field Handler FldIdent
|
||
checkFldUniqueCI wid = checkM $ \ fld -> do
|
||
sames <- runDB $ select $ from $ \ field -> do
|
||
where_ $
|
||
field ^. WorkflowFieldWorkflow ==. val wid &&.
|
||
lower_ (field ^. WorkflowFieldIdent) ==. lower_ (val fld)
|
||
limit 1
|
||
return ()
|
||
return $ if null sames
|
||
then Right fld
|
||
else Left ("There is already a field by that name" :: Text)
|
||
|
||
fieldIdentField :: Field Handler FldIdent
|
||
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
|
||
|
||
checkCtorName :: Field Handler Text -> Field Handler Text
|
||
checkCtorName =
|
||
let charOk c = isAlphaNum c || c == ' '
|
||
nameOk t = (not . T.null) t && T.all charOk t
|
||
msg :: Text
|
||
msg = "The name may contain only letters, digits and spaces."
|
||
in checkBool nameOk msg
|
||
|
||
checkCtorUnique
|
||
:: WorkflowFieldEnumId -> Field Handler Text -> Field Handler Text
|
||
checkCtorUnique eid = checkM $ \ name -> do
|
||
mc <- runDB $ getBy $ UniqueWorkflowFieldEnumCtor eid name
|
||
return $ case mc of
|
||
Nothing -> Right name
|
||
Just _ -> Left ("There is already an enum ctor by that name" :: Text)
|
||
|
||
ctorNameField :: Field Handler Text
|
||
ctorNameField = checkCtorName textField
|
||
|
||
newCtorNameField :: WorkflowFieldEnumId -> Field Handler Text
|
||
newCtorNameField eid = checkCtorUnique eid ctorNameField
|