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