1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Tag 3 ( queryTags 4 , postTag 5 , deleteTag 6 ) where 7 8 import qualified Data.Aeson as Aeson 9 import Control.Monad (unless) 10 import qualified Data.Text as T 11 import Network.HTTP.Types (conflict409) 12 import qualified Web.Route.Invertible as R 13 14 import Has 15 import Ops 16 import qualified JSON 17 import Model.Permission 18 import Model.Id 19 import Model.Container 20 import Model.Slot 21 import Model.Tag 22 import Model.Notification.Types 23 import Solr.Tag 24 -- import HTTP.Form.Deform 25 import HTTP.Path.Parser 26 import Action.Run 27 import Action 28 import Controller.Paths 29 -- import Controller.Form 30 import Controller.Permission 31 import Controller.Slot 32 import Controller.Notification 33 34 -- TODO: use validateTag after receiving string in url first, similar to below 35 -- _tagNameForm :: DeformHandler f TagName 36 -- _tagNameForm = deformMaybe' "Invalid tag name." . validateTag =<< deform 37 38 queryTags :: ActionRoute (Maybe TagName) 39 queryTags = action GET (pathJSON >/> "tags" >/> pathMaybe R.parameter) $ \t -> withoutAuth $ 40 okResponse [] . Aeson.encode . unwrap . QueryTagsResponse <$> termTags t 16 41 42 -- | Response body for queryTags 43 newtype QueryTagsResponse = QueryTagsResponse { unwrap :: [TagName] } 44 45 tagResponse :: API -> TagUse -> Handler Response 46 tagResponse JSON t = okResponse [] . JSON.recordEncoding . tagCoverageJSON <$> lookupTagCoverage (useTag t) (containerSlot $ slotContainer $ tagSlot t) 47 tagResponse HTML t = peeks $ otherRouteResponse [] (viewSlot False) (HTML, (Just (view t), slotId (tagSlot t))) 48 49 postTag :: ActionRoute (API, Id Slot, TagId) 50 postTag = action POST (pathAPI </>> pathSlotId </> pathTagId) $ \(api, si, TagId kw tn) -> withAuth $ do 51 guardVerfHeader 52 u <- authAccount 53 s <- getSlot (if kw then PermissionEDIT else PermissionSHARED) si 54 t <- addTag tn 55 let tu = TagUse t kw u s 56 r <- addTagUse tu 57 unless r $ result $ 58 response conflict409 [] ("The requested tag overlaps your existing tag." :: T.Text) 59 top <- containerIsVolumeTop (slotContainer s) 60 createVolumeNotification (view tu) $ \n -> (n NoticeTagVolume) 61 { notificationContainerId = top `unlessUse` view tu 62 , notificationSegment = Just $ (view . tagSlot) tu 63 , notificationTag = Just $ useTag tu 64 } 65 tagResponse api tu 66 67 deleteTag :: ActionRoute (API, Id Slot, TagId) 68 deleteTag = action DELETE (pathAPI </>> pathSlotId </> pathTagId) $ \(api, si, TagId kw tn) -> withAuth $ do 69 guardVerfHeader 70 u <- authAccount 71 s <- getSlot (if kw then PermissionEDIT else PermissionSHARED) si 72 t <- maybeAction =<< lookupTag tn 73 let tu = TagUse t kw u s 74 _r <- removeTagUse tu 75 tagResponse api tu