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