module Handler.Tags(
tagHeader
, tagWidget
, postRetagThreadR
, postRetagMessageR
, postCustomRetagThreadR
, postCustomRetagMessageR
) where
import Import
import qualified Data.Text as T
displayTag :: T.Text -> WidgetT App IO ()
displayTag "unread" = [whamlet|<span .label .labelimportant .labeltag>unread|]
displayTag t = [whamlet|<span .label .labelinfo .labeltag>#{t}|]
tagWidget :: Either SearchResult Message -> WidgetT App IO ()
tagWidget x = do
let url = case x of
Left s -> RetagThreadR (searchThread s)
Right m -> RetagMessageR (messageId m)
let customUrl = case x of
Left s -> CustomRetagThreadR (searchThread s)
Right m -> CustomRetagMessageR (messageId m)
let tags = either searchTags messageTags x
retags <- extraRetag <$> getExtra
[whamlet|
<span .tags>
<span .btngroup .hidenoscript>
$forall r <- retags
<button .btn .retagbutton .btnlink title="#{retagName r}" datanotmuchurl="@{url (retagName r)}">
<i class="#{retagIcon r}">
<button .btn .retagcustombutton .btnlink title=_{MsgMessageRetagging} datanotmuchurl=@{customUrl}>
<i .iconedit>
$forall tag <- tags
^{displayTag tag}
|]
retagForm :: Form ()
retagForm = renderDivs $ pure ()
customRetagForm :: Form (Maybe T.Text, Maybe T.Text)
customRetagForm =
renderBootstrap $ (,) <$> aopt textField (FieldSettings (SomeMessage MsgTagsToAdd) Nothing (Just "add") Nothing []) Nothing
<*> aopt textField (FieldSettings (SomeMessage MsgTagsToRemove) Nothing (Just "remove") Nothing []) Nothing
tagHeader :: Widget
tagHeader = do
(retagWidget,retagEnc) <- liftHandlerT $ generateFormPost retagForm
(customWidget,customEnc) <- liftHandlerT $ generateFormPost customRetagForm
$(widgetFile "tag-header")
postRetagThreadR :: ThreadID -> T.Text -> Handler Value
postRetagThreadR t name = do
((result,_),_) <- runFormPost retagForm
case result of
FormMissing -> invalidArgs ["form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess _ -> return ()
retags <- extraRetag <$> getExtra
let retag = filter (\r -> retagName r == name) retags
case retag of
[] -> notFound
(r:_) -> do notmuchTagThread (retagAdd r) (retagRemove r) t
return $ toJSON r
postRetagMessageR :: MessageID -> T.Text -> Handler Value
postRetagMessageR m name = do
((result,_),_) <- runFormPost retagForm
case result of
FormMissing -> invalidArgs ["form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess _ -> return ()
retags <- extraRetag <$> getExtra
let retag = filter (\r -> retagName r == name) retags
case retag of
[] -> notFound
(r:_) -> do notmuchTagMessage (retagAdd r) (retagRemove r) m
return $ toJSON r
postCustomRetagThreadR :: ThreadID -> Handler Value
postCustomRetagThreadR t = do
((result,_),_) <- runFormPost customRetagForm
(add, remove) <- case result of
FormMissing -> invalidArgs ["form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess (a,r) -> return (T.unpack <$> a, T.unpack <$> r)
let add' = maybe [] words add
rem' = maybe [] words remove
notmuchTagThread add' rem' t
return $ object [ "add" .= add', "remove" .= rem' ]
postCustomRetagMessageR :: MessageID -> Handler Value
postCustomRetagMessageR m = do
((result,_),_) <- runFormPost customRetagForm
(add, remove) <- case result of
FormMissing -> invalidArgs ["form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess (a,r) -> return (T.unpack <$> a, T.unpack <$> r)
let add' = maybe [] words add
rem' = maybe [] words remove
notmuchTagMessage add' rem' m
return $ object [ "add" .= add', "remove" .= rem' ]