introducint 2 modes for tags

This commit is contained in:
Filip Graliński 2018-06-27 13:32:45 +02:00
parent 7b7001845d
commit 4ec90bdb10
4 changed files with 42 additions and 17 deletions

View File

@ -11,24 +11,37 @@ import Handler.TagUtils
getTagsR :: Handler Html getTagsR :: Handler Html
getTagsR = do getTagsR = do
(formWidget, formEnctype) <- generateFormPost tagForm (formWidget, formEnctype) <- generateFormPost tagForm
mUser <- maybeAuth doTags formWidget formEnctype
doTags mUser formWidget formEnctype
postTagsR :: Handler Html postTagsR :: Handler Html
postTagsR = do postTagsR = do
((result, formWidget), formEnctype) <- runFormPost tagForm ((result, formWidget), formEnctype) <- runFormPost tagForm
mUser <- maybeAuth canTagsBeAdded <- canAddTags
when (checkIfAdmin mUser) $ do when canTagsBeAdded $ do
case result of case result of
FormSuccess (t, d) -> do FormSuccess (t, d) -> do
_ <- runDB $ insert $ Tag t d _ <- runDB $ insert $ Tag t d
return () return ()
_ -> do _ -> do
return () return ()
doTags mUser formWidget formEnctype doTags formWidget formEnctype
doTags mUser formWidget formEnctype = do
canAddTags :: Handler Bool
canAddTags = do
mUser <- maybeAuth
app <- getYesod
let tagPermissions = appTagPermissions $ appSettings app
case tagPermissions of
OnlyAdminCanAddNewTags -> return $ checkIfAdmin mUser
EverybodyCanAddNewTags -> return $ isJust mUser
doTags formWidget formEnctype = do
tags <- runDB $ selectList [] [Asc TagName] tags <- runDB $ selectList [] [Asc TagName]
canTagsBeAdded <- canAddTags
defaultLayout $ do defaultLayout $ do
setTitle "Tags" setTitle "Tags"
$(widgetFile "tags") $(widgetFile "tags")

View File

@ -19,12 +19,19 @@ import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
widgetFileReload) widgetFileReload)
data RepoScheme = SelfHosted | Branches data RepoScheme = SelfHosted | Branches
deriving(Eq, Show) deriving (Eq, Show)
toRepoScheme :: Text -> RepoScheme toRepoScheme :: Text -> RepoScheme
toRepoScheme "branches" = Branches toRepoScheme "branches" = Branches
toRepoScheme _ = SelfHosted toRepoScheme _ = SelfHosted
data TagPermissions = OnlyAdminCanAddNewTags | EverybodyCanAddNewTags
deriving (Eq, Show)
toTagPermissions :: Text -> TagPermissions
toTagPermissions "everybody-can-add-new-tags" = EverybodyCanAddNewTags
toTagPermissions _ = OnlyAdminCanAddNewTags
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database. -- theoretically even a database.
@ -71,6 +78,7 @@ data AppSettings = AppSettings
-- ^ Repo host -- ^ Repo host
, appRepoHost :: Text , appRepoHost :: Text
, appRepoScheme :: RepoScheme , appRepoScheme :: RepoScheme
, appTagPermissions :: TagPermissions
} }
instance FromJSON AppSettings where instance FromJSON AppSettings where
@ -108,6 +116,9 @@ instance FromJSON AppSettings where
scheme <- o .: "repo-scheme" scheme <- o .: "repo-scheme"
appRepoScheme <- return $ toRepoScheme scheme appRepoScheme <- return $ toRepoScheme scheme
tagPermissions <- o .: "tag-permissions"
appTagPermissions <- return $ toTagPermissions tagPermissions
return AppSettings {..} return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and -- | Settings for 'widgetFile', such as which template languages to support and

View File

@ -10,6 +10,7 @@ var-dir: "_env:VAR_DIR:."
contact-email: "_env:CONTACT_EMAIL:filipg@amu.edu.pl" contact-email: "_env:CONTACT_EMAIL:filipg@amu.edu.pl"
repo-host: "_env:REPO_HOST:ssh://gitolite@gonito.net/" repo-host: "_env:REPO_HOST:ssh://gitolite@gonito.net/"
repo-scheme: "_env:REPO_SCHEME:selfhosted" repo-scheme: "_env:REPO_SCHEME:selfhosted"
tag-permissions: "_env:TAG_PERMISSIONS:only-admin-can-add-new-tags"
# Optional values with the following production defaults. # Optional values with the following production defaults.
# In development, they default to the inverse. # In development, they default to the inverse.

View File

@ -4,7 +4,7 @@
<hr> <hr>
$if (checkIfAdmin mUser) $if canTagsBeAdded
<h2>Create a new tag <h2>Create a new tag
<form method=post action=@{TagsR}#form enctype=#{formEnctype}> <form method=post action=@{TagsR}#form enctype=#{formEnctype}>