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