1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, RecordWildCards, OverloadedStrings, DataKinds #-}
    2 module Databrary.Model.Tag
    3   ( module Databrary.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 Databrary.Has (peek)
   30 import qualified Databrary.JSON as JSON
   31 import Databrary.Service.DB
   32 import Databrary.Model.SQL
   33 import Databrary.Model.Party.Types
   34 import Databrary.Model.Identity.Types
   35 import Databrary.Model.Volume.Types
   36 import Databrary.Model.Container.Types
   37 import Databrary.Model.Slot.Types
   38 import Databrary.Model.Tag.Types
   39 import Databrary.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                  (Databrary.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))