gonito/Handler/TagUtils.hs

65 lines
2.6 KiB
Haskell
Raw Normal View History

2017-02-26 21:40:38 +01:00
module Handler.TagUtils where
import Import
import Yesod.Form.Bootstrap3 (bfs)
import Text.Blaze (ToMarkup)
2017-02-26 21:40:38 +01:00
import qualified Data.Set as S
getAvailableTagsAsJSON :: (BaseBackend backend ~ SqlBackend, MonadIO m, PersistQueryRead backend) => ReaderT backend m Value
2017-02-26 21:40:38 +01:00
getAvailableTagsAsJSON = do
tagsAvailable <- selectList [] [Asc TagName]
return $ toJSON $ Import.map (tagName . entityVal) tagsAvailable
tagsfs :: RenderMessage site msg => msg -> FieldSettings site
tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)}
where attrs = bfs msg
addTags :: (BaseBackend backend ~ SqlBackend, Element mono ~ Key Tag, Eq (Element mono), MonoFoldable mono, PersistQueryWrite backend, MonadIO m, PersistUniqueRead backend) => Key Submission -> S.Set Text -> mono -> ReaderT backend m ()
addTags submissionId tags existingOnes = do
tids <- tagsAsTextToTagIds tags
2017-09-27 19:38:42 +02:00
deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids]
_ <- mapM (\tid -> insert $ SubmissionTag submissionId tid Nothing) (Import.filter (not . (`elem` existingOnes)) tids)
return ()
2017-02-26 21:40:38 +01:00
tagsAsTextToTagIds :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, MonadIO m) => S.Set Text -> ReaderT backend m [Key Tag]
tagsAsTextToTagIds tags = do
let newTags = S.toList $ tags
2017-02-26 21:40:38 +01:00
mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
return $ Import.map entityKey $ Import.catMaybes mTs
2017-03-18 15:57:27 +01:00
fragmentWithTags :: (Text.Blaze.ToMarkup a, Foldable t) => a -> t (Entity Tag) -> WidgetFor site ()
2017-03-18 15:57:27 +01:00
fragmentWithTags t tagEnts = [whamlet|
#{t}
$forall (Entity _ v) <- tagEnts
\ <span class="label label-primary">#{tagName v}</span>
|]
2017-05-27 22:31:53 +02:00
fragmentWithSubmissionTags :: (Text.Blaze.ToMarkup a, Foldable t) => a -> Maybe (Route site) -> t (Entity Tag, Entity SubmissionTag) -> WidgetFor site ()
2018-11-03 21:37:44 +01:00
fragmentWithSubmissionTags t mLink tagEnts = [whamlet|
$maybe link <- mLink
<a href="@{link}">#{t}</a>
$nothing
#{t}
2017-05-27 22:31:53 +02:00
2017-05-28 10:06:50 +02:00
$forall ((Entity _ v), (Entity sid s)) <- tagEnts
\ <span class="label #{tagClass $ submissionTagAccepted s}" onclick="t=$(this); $.get('/toggle-submission-tag/#{toPathPiece sid}', function(data){ if (!(data == 'BLOCKED')) {t.removeClass('#{allTagClasses}'); t.addClass(data);} }); ">#{tagName v}</span>
2017-05-27 22:31:53 +02:00
|]
2017-05-28 10:06:50 +02:00
allTagClasses :: Text
allTagClasses = (tagClass $ Just True) <> " " <> (tagClass $ Just False) <> " " <> (tagClass $ Nothing);
2017-05-27 22:31:53 +02:00
tagClass :: Maybe Bool -> Text
tagClass (Just True) = "label-success"
tagClass (Just False) = "label-default"
tagClass Nothing = "label-primary"
2017-05-28 10:06:50 +02:00
toggleTag :: Maybe Bool -> Maybe Bool
toggleTag (Just True) = Just False
toggleTag _ = Just True