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