1 {-# LANGUAGE TemplateHaskell #-}
    2 module Databrary.Model.Tag.SQL
    3   ( selectTag
    4   , selectTagUseRow
    5   , insertTagUse
    6   , deleteTagUse
    7   , selectTagWeight
    8   , selectTagCoverage
    9   , selectSlotTagCoverage
   10   -- for expanded queries
   11   , makeTagUseRow
   12   ) where
   13 
   14 import Data.List (intercalate)
   15 import Data.Maybe (fromMaybe)
   16 import Database.PostgreSQL.Typed.Query (makePGQuery, simpleQueryFlags)
   17 import qualified Language.Haskell.TH as TH
   18 
   19 import Databrary.Model.SQL.Select
   20 import Databrary.Model.Id.Types
   21 import Databrary.Model.Party.Types
   22 import Databrary.Model.Container.Types
   23 import Databrary.Model.Segment
   24 import Databrary.Model.Slot.Types
   25 import Databrary.Model.Tag.Types
   26 
   27 tagRow :: Selector -- ^ @'Tag'@
   28 tagRow = selectColumns 'Tag "tag" ["id", "name"]
   29 
   30 selectTag :: Selector -- ^ @'Tag'@
   31 selectTag = tagRow
   32 
   33 tagUseTable :: Bool -> String
   34 tagUseTable False = "tag_use"
   35 tagUseTable True = "keyword_use"
   36 
   37 makeTagUseRow :: Id Party -> Id Container -> Segment -> Maybe Bool -> Tag -> TagUseRow
   38 makeTagUseRow w c s k t = TagUseRow t (fromMaybe False k) w (SlotId c s)
   39 
   40 tagUseRow :: Selector -- ' @'Tag' -> 'TagUseRow'@
   41 tagUseRow = addSelects '($)
   42   (selectColumns 'makeTagUseRow "tag_use" ["who", "container", "segment"])
   43   [SelectExpr "tag_use.tableoid = 'keyword_use'::regclass"]
   44 
   45 selectTagUseRow :: Selector -- ^ @'TagUseId'@
   46 selectTagUseRow = selectJoin '($)
   47   [ tagUseRow
   48   , joinOn "tag_use.tag = tag.id"
   49     tagRow
   50   ]
   51 
   52 insertTagUse :: Bool -- ^ keyword
   53   -> TH.Name -- ^ @'TagUse'@
   54   -> TH.ExpQ
   55 insertTagUse keyword o = makePGQuery simpleQueryFlags $
   56   "INSERT INTO " ++ tagUseTable keyword ++ " (tag, container, segment, who) VALUES (${tagId $ useTag " ++ os ++ "}, ${containerId $ containerRow $ slotContainer $ tagSlot  " ++ os ++ "}, ${slotSegment $ tagSlot  " ++ os ++ "}, ${partyId $ partyRow $ accountParty $ tagWho  " ++ os ++ "})"
   57   where os = nameRef o
   58 
   59 deleteTagUse :: Bool -- ^ keyword
   60   -> TH.Name -- ^ @'TagUse'@
   61   -> TH.ExpQ
   62 deleteTagUse keyword o = makePGQuery simpleQueryFlags $
   63   "DELETE FROM ONLY " ++ tagUseTable keyword ++ " WHERE tag = ${tagId $ useTag " ++ os ++ "} AND container = ${containerId $ containerRow $ slotContainer $ tagSlot " ++ os ++ "} AND segment <@ ${slotSegment $ tagSlot " ++ os ++ "}"
   64   ++ (if keyword then "" else " AND who = ${partyId $ partyRow $ accountParty $ tagWho " ++ os ++ "}")
   65   where os = nameRef o
   66 
   67 selectTagGroup :: String -- ^ table name
   68   -> String -- ^ query
   69   -> TH.Name -- ^ make function
   70   -> [(String, String)] -- ^ select columns (alias, select)
   71   -> Selector
   72 selectTagGroup name q make cols = selector
   73   ("(SELECT tag," ++ intercalate "," (map (\(a, s) -> s ++ " AS " ++ a) cols)
   74     ++ " FROM tag_use " ++ q ++ " GROUP BY tag) AS " ++ name)
   75   $ OutputJoin False make $ map (SelectColumn name . fst) cols
   76 
   77 tagWeightColumns :: [(String, String)]
   78 tagWeightColumns =
   79   [ ("weight", "count(*)::integer")
   80   ]
   81 
   82 makeTagWeight :: Int32 -> Tag -> TagWeight
   83 makeTagWeight w t = TagWeight t w
   84 
   85 selectTagWeight :: String -> Selector -- ^ @'TagCoverage'@
   86 selectTagWeight q = selectJoin '($)
   87   [ selectTagGroup "tag_weight" q 'makeTagWeight tagWeightColumns
   88   , joinOn "tag_weight.tag = tag.id" selectTag
   89   ]
   90 
   91 makeTagCoverage :: Int32 -> [Maybe Segment] -> [Maybe Segment] -> [Maybe Segment] -> Tag -> Container -> TagCoverage
   92 makeTagCoverage w s k v t c = TagCoverage (TagWeight t w) c (segs s) (segs k) (segs v) where
   93   segs = map $ fromMaybe (error "NULL tag segment")
   94 
   95 tagCoverageColumns :: TH.Name -- ^ @'Party'@
   96   -> [(String, String)]
   97 tagCoverageColumns acct = tagWeightColumns ++
   98   [ ("coverage", "segments_union(segment)")
   99   , ("keywords", "segments_union(CASE WHEN tableoid = 'keyword_use'::regclass THEN segment ELSE 'empty' END)")
  100   , ("votes", "segments_union(CASE WHEN tableoid = 'tag_use'::regclass AND who = ${partyId $ partyRow " ++ nameRef acct ++ "} THEN segment ELSE 'empty' END)")
  101   ]
  102 
  103 selectTagCoverage :: TH.Name -- ^ @'Party'@
  104   -> String -- ^ query
  105   -> Selector -- ^ @'Tag' -> 'Container' -> 'TagCoverage'@
  106 selectTagCoverage acct q =
  107   selectTagGroup "tag_coverage" q 'makeTagCoverage $ tagCoverageColumns acct
  108 
  109 selectSlotTagCoverage :: TH.Name -- ^ @'Party'@
  110   -> TH.Name -- ^ @'Slot'
  111   -> Selector -- ^ @'TagCoverage'@
  112 selectSlotTagCoverage acct slot = selectMap (`TH.AppE` (TH.VarE 'slotContainer `TH.AppE` TH.VarE slot)) $ selectJoin '($)
  113   [ selectTagCoverage acct $ "WHERE container = ${containerId $ containerRow $ slotContainer " ++ ss ++ "} AND segment && ${slotSegment " ++ ss ++ "}"
  114   , joinOn "tag_coverage.tag = tag.id" selectTag
  115   ] where ss = nameRef slot