forked from filipg/gonito
130 lines
4.0 KiB
Haskell
130 lines
4.0 KiB
Haskell
{-# LANGUAGE OverloadedLists #-}
|
|
|
|
module Handler.Tags where
|
|
|
|
import Import hiding (fromList, get)
|
|
import Handler.Common (checkIfAdmin)
|
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
import Handler.TagUtils
|
|
|
|
import Data.Swagger.Declare
|
|
import Data.Swagger hiding (Tag, tags)
|
|
import Data.Proxy as DPR
|
|
import Control.Lens hiding ((.=))
|
|
import Data.HashMap.Strict.InsOrd (fromList)
|
|
|
|
instance ToJSON (Entity Tag) where
|
|
toJSON v = object
|
|
[ "name" .= (tagName $ entityVal v)
|
|
, "description" .= (tagDescription $ entityVal v)
|
|
, "id" .= (entityKey v)
|
|
]
|
|
|
|
instance ToSchema (Entity Tag) where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
|
|
return $ NamedSchema (Just "Tag") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("name", stringSchema)
|
|
, ("description", stringSchema)
|
|
, ("id", intSchema)
|
|
]
|
|
& required .~ [ "name", "description", "id" ]
|
|
|
|
listTagsApi :: Swagger
|
|
listTagsApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareListTagsSwagger mempty
|
|
|
|
declareListTagsSwagger :: Declare (Definitions Schema) Swagger
|
|
declareListTagsSwagger = do
|
|
listTagsResponse <- declareResponse (DPR.Proxy :: DPR.Proxy [Entity Tag])
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
[ ("/api/list-tags", mempty & get ?~ (mempty
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Returns the list of all tags"
|
|
& at 200 ?~ Inline listTagsResponse))
|
|
]
|
|
|
|
|
|
getListTagsJsonR :: Handler Value
|
|
getListTagsJsonR = do
|
|
allTags <- fetchAllTags
|
|
return $ toJSON allTags
|
|
|
|
getTagsR :: Handler Html
|
|
getTagsR = do
|
|
(formWidget, formEnctype) <- generateFormPost tagForm
|
|
doTags formWidget formEnctype
|
|
|
|
postTagsR :: Handler Html
|
|
postTagsR = do
|
|
((result, formWidget), formEnctype) <- runFormPost tagForm
|
|
canTagsBeAdded <- canAddTags
|
|
when canTagsBeAdded $ do
|
|
case result of
|
|
FormSuccess (t, d) -> do
|
|
_ <- runDB $ insert $ Tag t d
|
|
return ()
|
|
_ -> do
|
|
return ()
|
|
doTags formWidget formEnctype
|
|
|
|
|
|
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
|
|
|
|
|
|
fetchAllTags :: (PersistQueryRead (YesodPersistBackend site),
|
|
YesodPersist site,
|
|
BaseBackend (YesodPersistBackend site) ~ SqlBackend)
|
|
=> HandlerFor site [Entity Tag]
|
|
fetchAllTags = runDB $ selectList [] [Asc TagName]
|
|
|
|
doTags formWidget formEnctype = do
|
|
tags <- fetchAllTags
|
|
canTagsBeAdded <- canAddTags
|
|
defaultLayout $ do
|
|
setTitle "Tags"
|
|
$(widgetFile "tags")
|
|
|
|
tagsTable :: Table.Table App (Entity Tag)
|
|
tagsTable = mempty
|
|
++ Table.text "tag" (\(Entity _ tag) -> tagName tag)
|
|
++ Table.text "description" (\(Entity _ tag) -> (fromMaybe (""::Text) (tagDescription tag)))
|
|
|
|
|
|
tagForm :: Form (Text, Maybe Text)
|
|
tagForm = renderBootstrap3 BootstrapBasicForm $ (,)
|
|
<$> areq textField (bfs MsgTagName) Nothing
|
|
<*> aopt textField (bfs MsgTagDescription) Nothing
|
|
|
|
getToggleSubmissionTagR :: SubmissionTagId -> Handler RepPlain
|
|
getToggleSubmissionTagR submissionTagId = do
|
|
mUser <- maybeAuth
|
|
if (checkIfAdmin mUser)
|
|
then
|
|
do
|
|
submissionTag <- runDB $ get404 submissionTagId
|
|
let newState = toggleTag $ submissionTagAccepted submissionTag
|
|
runDB $ update submissionTagId [SubmissionTagAccepted =. newState]
|
|
return $ RepPlain $ toContent $ tagClass newState
|
|
else
|
|
do
|
|
return $ RepPlain $ toContent ("BLOCKED" :: Text)
|