1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, RecordWildCards, OverloadedStrings, DataKinds #-} 2 module Model.Tag 3 ( module Model.Tag.Types 4 , lookupTag 5 , lookupTags 6 , findTags 7 , addTag 8 , lookupVolumeTagUseRows 9 , addTagUse 10 , removeTagUse 11 , lookupTopTagWeight 12 , lookupTagCoverage 13 , lookupSlotTagCoverage 14 , lookupSlotKeywords 15 , tagWeightJSON 16 , tagCoverageJSON 17 ) where 18 19 import Control.Applicative (empty, pure) 20 import Control.Monad (guard) 21 import qualified Data.ByteString.Char8 as BSC 22 import Data.Int (Int64) 23 import Data.Maybe (fromMaybe) 24 import Data.Monoid ((<>)) 25 import qualified Data.String 26 -- import Database.PostgreSQL.Typed (pgSQL) 27 import Database.PostgreSQL.Typed.Types 28 29 import Has (peek) 30 import qualified JSON 31 import Service.DB 32 import Model.SQL 33 import Model.Party.Types 34 import Model.Identity.Types 35 import Model.Volume.Types 36 import Model.Container.Types 37 import Model.Slot.Types 38 import Model.Tag.Types 39 import Model.Tag.SQL 40 41 lookupTag :: MonadDB c m => TagName -> m (Maybe Tag) 42 lookupTag n = 43 dbQuery1 $(selectQuery selectTag "$WHERE tag.name = ${n}::varchar") 44 45 lookupTags :: MonadDB c m => m [Tag] 46 lookupTags = do 47 let _tenv_a6Dq8 = unknownPGTypeEnv 48 rows <- dbQuery -- (selectQuery selectTag "") 49 (mapQuery2 50 (BSC.concat 51 [Data.String.fromString "SELECT tag.id,tag.name FROM tag "]) 52 (\ [_cid_a6Dq9, _cname_a6Dqa] 53 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 54 _tenv_a6Dq8 55 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 56 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 57 _cid_a6Dq9, 58 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 59 _tenv_a6Dq8 60 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 61 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 62 _cname_a6Dqa))) 63 pure 64 (fmap 65 (\ (vid_a6Dpn, vname_a6Dpo) -> Tag vid_a6Dpn vname_a6Dpo) 66 rows) 67 68 findTags :: MonadDB c m => TagName -> Int -> m [Tag] 69 findTags (TagName n) lim = -- TagName restrictions obviate pattern escaping 70 dbQuery $(selectQuery selectTag "$WHERE tag.name LIKE ${n `BSC.snoc` '%'}::varchar LIMIT ${fromIntegral lim :: Int64}") 71 72 addTag :: MonadDB c m => TagName -> m Tag 73 addTag n = do 74 let _tenv_a6GtM = unknownPGTypeEnv 75 row <- dbQuery1' -- [pgSQL|!SELECT get_tag(${n})|] 76 (mapQuery2 77 ((\ _p_a6GtN -> 78 BSC.concat 79 [Data.String.fromString "SELECT get_tag(", 80 Database.PostgreSQL.Typed.Types.pgEscapeParameter 81 _tenv_a6GtM 82 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 83 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 84 _p_a6GtN, 85 Data.String.fromString ")"]) 86 n) 87 (\ [_cget_tag_a6GtO] 88 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 89 _tenv_a6GtM 90 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 91 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 92 _cget_tag_a6GtO))) 93 pure ((`Tag` n) row) 94 95 lookupVolumeTagUseRows :: MonadDB c m => Volume -> m [TagUseRow] 96 lookupVolumeTagUseRows v = do 97 let _tenv_a6PCr = unknownPGTypeEnv 98 rows <- dbQuery -- (selectQuery selectTagUseRow "JOIN container ON tag_use.container = container.id WHERE container.volume = ${volumeId $ volumeRow v} ORDER BY container.id") 99 (mapQuery2 100 ((\ _p_a6PCs -> 101 BSC.concat 102 [Data.String.fromString 103 "SELECT tag_use.who,tag_use.container,tag_use.segment,tag_use.tableoid = 'keyword_use'::regclass,tag.id,tag.name FROM tag_use JOIN tag ON tag_use.tag = tag.id JOIN container ON tag_use.container = container.id WHERE container.volume = ", 104 Database.PostgreSQL.Typed.Types.pgEscapeParameter 105 _tenv_a6PCr 106 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 107 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 108 _p_a6PCs, 109 Data.String.fromString " ORDER BY container.id"]) 110 (volumeId $ volumeRow v)) 111 (\ 112 [_cwho_a6PCt, 113 _ccontainer_a6PCu, 114 _csegment_a6PCv, 115 _ccolumn_a6PCw, 116 _cid_a6PCx, 117 _cname_a6PCy] 118 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 119 _tenv_a6PCr 120 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 121 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 122 _cwho_a6PCt, 123 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 124 _tenv_a6PCr 125 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 126 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 127 _ccontainer_a6PCu, 128 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 129 _tenv_a6PCr 130 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 131 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 132 _csegment_a6PCv, 133 Database.PostgreSQL.Typed.Types.pgDecodeColumn 134 _tenv_a6PCr 135 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 136 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 137 _ccolumn_a6PCw, 138 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 139 _tenv_a6PCr 140 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 141 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 142 _cid_a6PCx, 143 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 144 _tenv_a6PCr 145 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 146 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 147 _cname_a6PCy))) 148 pure 149 (fmap 150 (\ (vwho_a6PC1, vcontainer_a6PC2, vsegment_a6PC3, vregclass_a6PC4, 151 vid_a6PC5, vname_a6PC6) 152 -> ($) 153 (($) 154 (Model.Tag.SQL.makeTagUseRow 155 vwho_a6PC1 vcontainer_a6PC2 vsegment_a6PC3) 156 vregclass_a6PC4) 157 (Tag vid_a6PC5 vname_a6PC6)) 158 rows) 159 160 161 addTagUse :: MonadDB c m => TagUse -> m Bool 162 addTagUse t = either (const False) id <$> do 163 let (_tenv_a6PDJ, _tenv_a6PEH) = (unknownPGTypeEnv, unknownPGTypeEnv) 164 dbTryJust (guard . isExclusionViolation) 165 $ dbExecute1 (if tagKeyword t 166 then -- (insertTagUse True 't) 167 mapQuery2 168 ((\ _p_a6PDK _p_a6PDL _p_a6PDM _p_a6PDN -> 169 (BSC.concat 170 [Data.String.fromString 171 "INSERT INTO keyword_use (tag, container, segment, who) VALUES (", 172 Database.PostgreSQL.Typed.Types.pgEscapeParameter 173 _tenv_a6PDJ 174 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 175 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 176 _p_a6PDK, 177 Data.String.fromString ", ", 178 Database.PostgreSQL.Typed.Types.pgEscapeParameter 179 _tenv_a6PDJ 180 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 181 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 182 _p_a6PDL, 183 Data.String.fromString ", ", 184 Database.PostgreSQL.Typed.Types.pgEscapeParameter 185 _tenv_a6PDJ 186 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 187 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 188 _p_a6PDM, 189 Data.String.fromString ", ", 190 Database.PostgreSQL.Typed.Types.pgEscapeParameter 191 _tenv_a6PDJ 192 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 193 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 194 _p_a6PDN, 195 Data.String.fromString ")"])) 196 (tagId $ useTag t) 197 (containerId $ containerRow $ slotContainer $ tagSlot t) 198 (slotSegment $ tagSlot t) 199 (partyId $ partyRow $ accountParty $ tagWho t)) 200 (\[] -> ()) 201 else -- (insertTagUse False 't)) 202 mapQuery2 203 ((\ _p_a6PEI _p_a6PEJ _p_a6PEK _p_a6PEL -> 204 (BSC.concat 205 [Data.String.fromString 206 "INSERT INTO tag_use (tag, container, segment, who) VALUES (", 207 Database.PostgreSQL.Typed.Types.pgEscapeParameter 208 _tenv_a6PEH 209 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 210 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 211 _p_a6PEI, 212 Data.String.fromString ", ", 213 Database.PostgreSQL.Typed.Types.pgEscapeParameter 214 _tenv_a6PEH 215 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 216 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 217 _p_a6PEJ, 218 Data.String.fromString ", ", 219 Database.PostgreSQL.Typed.Types.pgEscapeParameter 220 _tenv_a6PEH 221 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 222 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 223 _p_a6PEK, 224 Data.String.fromString ", ", 225 Database.PostgreSQL.Typed.Types.pgEscapeParameter 226 _tenv_a6PEH 227 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 228 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 229 _p_a6PEL, 230 Data.String.fromString ")"])) 231 (tagId $ useTag t) 232 (containerId $ containerRow $ slotContainer $ tagSlot t) 233 (slotSegment $ tagSlot t) 234 (partyId $ partyRow $ accountParty $ tagWho t)) 235 (\[] -> ())) 236 237 removeTagUse :: MonadDB c m => TagUse -> m Int 238 removeTagUse t = do 239 let (_tenv_a6PFr, _tenv_a6PGB) = (unknownPGTypeEnv, unknownPGTypeEnv) 240 dbExecute 241 (if tagKeyword t 242 then -- (deleteTagUse True 't) 243 mapQuery2 244 ((\ _p_a6PFs _p_a6PFt _p_a6PFu -> 245 (BSC.concat 246 [Data.String.fromString 247 "DELETE FROM ONLY keyword_use WHERE tag = ", 248 Database.PostgreSQL.Typed.Types.pgEscapeParameter 249 _tenv_a6PFr 250 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 251 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 252 _p_a6PFs, 253 Data.String.fromString " AND container = ", 254 Database.PostgreSQL.Typed.Types.pgEscapeParameter 255 _tenv_a6PFr 256 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 257 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 258 _p_a6PFt, 259 Data.String.fromString " AND segment <@ ", 260 Database.PostgreSQL.Typed.Types.pgEscapeParameter 261 _tenv_a6PFr 262 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 263 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 264 _p_a6PFu])) 265 (tagId $ useTag t) 266 (containerId $ containerRow $ slotContainer $ tagSlot t) 267 (slotSegment $ tagSlot t)) 268 (\[] -> ()) 269 else -- (deleteTagUse False 't)) 270 mapQuery2 271 ((\ _p_a6PGC _p_a6PGD _p_a6PGE _p_a6PGF -> 272 (BSC.concat 273 [Data.String.fromString "DELETE FROM ONLY tag_use WHERE tag = ", 274 Database.PostgreSQL.Typed.Types.pgEscapeParameter 275 _tenv_a6PGB 276 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 277 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 278 _p_a6PGC, 279 Data.String.fromString " AND container = ", 280 Database.PostgreSQL.Typed.Types.pgEscapeParameter 281 _tenv_a6PGB 282 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 283 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 284 _p_a6PGD, 285 Data.String.fromString " AND segment <@ ", 286 Database.PostgreSQL.Typed.Types.pgEscapeParameter 287 _tenv_a6PGB 288 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 289 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 290 _p_a6PGE, 291 Data.String.fromString " AND who = ", 292 Database.PostgreSQL.Typed.Types.pgEscapeParameter 293 _tenv_a6PGB 294 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 295 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 296 _p_a6PGF])) 297 (tagId $ useTag t) 298 (containerId $ containerRow $ slotContainer $ tagSlot t) 299 (slotSegment $ tagSlot t) 300 (partyId $ partyRow $ accountParty $ tagWho t)) 301 (\[] -> ())) 302 303 lookupTopTagWeight :: MonadDB c m => Int -> m [TagWeight] 304 lookupTopTagWeight lim = 305 dbQuery $(selectQuery (selectTagWeight "") "$!ORDER BY weight DESC LIMIT ${fromIntegral lim :: Int64}") 306 307 emptyTagCoverage :: Tag -> Container -> TagCoverage 308 emptyTagCoverage t c = TagCoverage (TagWeight t 0) c [] [] [] 309 310 lookupTagCoverage :: (MonadDB c m, MonadHasIdentity c m) => Tag -> Slot -> m TagCoverage 311 lookupTagCoverage t (Slot c s) = do 312 ident <- peek 313 fromMaybe (emptyTagCoverage t c) <$> dbQuery1 (($ c) . ($ t) <$> $(selectQuery (selectTagCoverage 'ident "WHERE container = ${containerId $ containerRow c} AND segment && ${s} AND tag = ${tagId t}") "$!")) 314 315 lookupSlotTagCoverage :: (MonadDB c m, MonadHasIdentity c m) => Slot -> Int -> m [TagCoverage] 316 lookupSlotTagCoverage slot lim = do 317 ident <- peek 318 dbQuery $(selectQuery (selectSlotTagCoverage 'ident 'slot) "$!ORDER BY weight DESC LIMIT ${fromIntegral lim :: Int64}") 319 320 lookupSlotKeywords :: (MonadDB c m) => Slot -> m [Tag] 321 lookupSlotKeywords Slot{..} = do 322 let _tenv_a6Q2M = unknownPGTypeEnv 323 rows <- dbQuery -- (selectQuery selectTag "JOIN keyword_use ON id = tag WHERE container = ${containerId $ containerRow slotContainer} AND segment = ${slotSegment}") 324 (mapQuery2 325 ((\ _p_a6Q2N _p_a6Q2O -> 326 (BSC.concat 327 [Data.String.fromString 328 "SELECT tag.id,tag.name FROM tag JOIN keyword_use ON id = tag WHERE container = ", 329 Database.PostgreSQL.Typed.Types.pgEscapeParameter 330 _tenv_a6Q2M 331 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 332 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 333 _p_a6Q2N, 334 Data.String.fromString " AND segment = ", 335 Database.PostgreSQL.Typed.Types.pgEscapeParameter 336 _tenv_a6Q2M 337 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 338 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 339 _p_a6Q2O])) 340 (containerId $ containerRow slotContainer) slotSegment) 341 (\ [_cid_a6Q2P, _cname_a6Q2Q] 342 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 343 _tenv_a6Q2M 344 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 345 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 346 _cid_a6Q2P, 347 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 348 _tenv_a6Q2M 349 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 350 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 351 _cname_a6Q2Q))) 352 pure 353 (fmap 354 (\ (vid_a6Q1R, vname_a6Q1S) -> Tag vid_a6Q1R vname_a6Q1S) 355 rows) 356 357 tagWeightJSON :: JSON.ToObject o => TagWeight -> JSON.Record TagName o 358 tagWeightJSON TagWeight{..} = JSON.Record (tagName tagWeightTag) $ 359 "weight" JSON..= tagWeightWeight 360 361 tagCoverageJSON :: JSON.ToObject o => TagCoverage -> JSON.Record TagName o 362 tagCoverageJSON TagCoverage{..} = tagWeightJSON tagCoverageWeight `JSON.foldObjectIntoRec` 363 ( "coverage" JSON..= tagCoverageSegments 364 <> "keyword" `JSON.kvObjectOrEmpty` (if null tagCoverageKeywords then empty else pure tagCoverageKeywords) 365 <> "vote" `JSON.kvObjectOrEmpty` (if null tagCoverageVotes then empty else pure tagCoverageVotes))