1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeFamilies, DataKinds, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 module Databrary.Model.Tag.Types 3 ( TagName(..) 4 , validateTag 5 , Tag(..) 6 , TagUse(..) 7 , TagUseRow(..) 8 , TagCoverage(..) 9 , TagWeight(..) 10 ) where 11 12 import qualified Data.ByteString as BS 13 import qualified Data.ByteString.Char8 as BSC 14 import Data.Char (toLower) 15 import qualified Data.Text.Encoding as TE 16 import Data.Typeable (Typeable) 17 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..)) 18 import qualified Text.Regex.Posix as Regex 19 import qualified Web.Route.Invertible as R 20 21 import Databrary.Ops 22 import Databrary.Has (Has(..)) 23 import qualified Databrary.JSON as JSON 24 import Databrary.Model.Kind 25 import Databrary.Model.Id.Types 26 import Databrary.Model.Party.Types 27 import Databrary.Model.Container.Types 28 import Databrary.Model.Segment 29 import Databrary.Model.Slot.Types 30 import Databrary.Model.Volume.Types 31 32 newtype TagName = TagName { tagNameBS :: BS.ByteString } deriving (JSON.ToJSON, JSON.FromJSON, Typeable, Show, Eq) 33 34 validTag :: Regex.Regex 35 validTag = Regex.makeRegex 36 ("^[a-z][-a-z ]+[a-z]$" :: BS.ByteString) 37 38 validateTag :: BS.ByteString -> Maybe TagName 39 validateTag t = (Regex.matchTest validTag tt) `thenUse` (TagName tt) where 40 tt = BSC.map toLower $ BSC.unwords $ BSC.words t 41 42 instance R.Parameter R.PathString TagName where 43 parseParameter = validateTag . TE.encodeUtf8 44 renderParameter = TE.decodeLatin1 . tagNameBS 45 46 instance PGParameter "character varying" TagName where 47 pgEncode t (TagName n) = pgEncode t n 48 pgEncodeValue e t (TagName n) = pgEncodeValue e t n 49 pgLiteral t (TagName n) = pgLiteral t n 50 instance PGColumn "character varying" TagName where 51 pgDecode t = TagName . pgDecode t 52 pgDecodeValue e t = TagName . pgDecodeValue e t 53 54 type instance IdType Tag = Int32 55 56 data Tag = Tag 57 { tagId :: Id Tag 58 , tagName :: TagName 59 } 60 61 -- makeHasRec ''Tag ['tagId, 'tagName] 62 -- instance Has (Id Tag) Tag where 63 -- view = tagId 64 -- instance Has TagName Tag where 65 -- view = tagName 66 67 instance Kinded Tag where 68 kindOf _ = "tag" 69 70 data TagUse = TagUse 71 { useTag :: Tag 72 , tagKeyword :: Bool 73 , tagWho :: Account 74 , tagSlot :: Slot 75 } 76 77 -- makeHasRec ''TagUse ['useTag, 'tagWho, 'tagSlot] 78 instance Has Tag TagUse where 79 view = useTag 80 -- instance Has (Id Tag) TagUse where 81 -- view = (view . useTag) 82 -- instance Has TagName TagUse where 83 -- view = (view . useTag) 84 -- instance Has Account TagUse where 85 -- view = tagWho 86 -- instance Has (Id Party) TagUse where 87 -- view = (view . tagWho) 88 -- instance Has PartyRow TagUse where 89 -- view = (view . tagWho) 90 -- instance Has Party TagUse where 91 -- view = (view . tagWho) 92 -- instance Has Slot TagUse where 93 -- view = tagSlot 94 instance Has Segment TagUse where 95 view = (view . tagSlot) 96 -- instance Has ContainerRow TagUse where 97 -- view = (view . tagSlot) 98 instance Has (Id Container) TagUse where 99 view = (view . tagSlot) 100 -- instance Has (Maybe Databrary.Model.Release.Types.Release) TagUse where 101 -- view = (view . tagSlot) 102 -- instance Has Databrary.Model.Release.Types.Release TagUse where 103 -- view = (view . tagSlot) 104 instance Has Databrary.Model.Volume.Types.Volume TagUse where 105 view = (view . tagSlot) 106 -- instance Has Databrary.Model.Permission.Types.Permission TagUse where 107 -- view = (view . tagSlot) 108 instance Has (Id Databrary.Model.Volume.Types.Volume) TagUse where 109 view = (view . tagSlot) 110 -- instance Has Databrary.Model.Volume.Types.VolumeRow TagUse where 111 -- view = (view . tagSlot) 112 -- instance Has Container TagUse where 113 -- view = (view . tagSlot) 114 115 data TagUseRow = TagUseRow 116 { useTagRow :: Tag 117 , tagRowKeyword :: Bool 118 , tagRowWhoId :: Id Party 119 , tagRowSlotId :: SlotId 120 } 121 122 data TagWeight = TagWeight 123 { tagWeightTag :: Tag 124 , tagWeightWeight :: Int32 125 } 126 127 -- makeHasRec ''TagWeight ['tagWeightTag] 128 -- instance Has Tag TagWeight where 129 -- view = tagWeightTag 130 -- instance Has (Id Tag) TagWeight where 131 -- view = (view . tagWeightTag) 132 -- instance Has TagName TagWeight where 133 -- view = (view . tagWeightTag) 134 135 data TagCoverage = TagCoverage 136 { tagCoverageWeight :: !TagWeight 137 , tagCoverageContainer :: Container 138 , tagCoverageSegments 139 , tagCoverageKeywords 140 , tagCoverageVotes :: [Segment] 141 } 142 143 -- makeHasRec ''TagCoverage ['tagCoverageWeight, 'tagCoverageContainer] 144 -- instance Has TagWeight TagCoverage where 145 -- view = tagCoverageWeight 146 -- instance Has Tag TagCoverage where 147 -- view = (view . tagCoverageWeight) 148 -- instance Has (Id Tag) TagCoverage where 149 -- view = (view . tagCoverageWeight) 150 -- instance Has TagName TagCoverage where 151 -- view = (view . tagCoverageWeight) 152 -- instance Has Container TagCoverage where 153 -- view = tagCoverageContainer 154 -- instance Has Databrary.Model.Volume.Types.VolumeRow TagCoverage where 155 -- view = (view . tagCoverageContainer) 156 -- instance Has (Id Databrary.Model.Volume.Types.Volume) TagCoverage where 157 -- view = (view . tagCoverageContainer) 158 -- instance Has Databrary.Model.Permission.Types.Permission TagCoverage where 159 -- view = (view . tagCoverageContainer) 160 -- instance Has Databrary.Model.Volume.Types.Volume TagCoverage where 161 -- view = (view . tagCoverageContainer) 162 -- instance Has Databrary.Model.Release.Types.Release TagCoverage where 163 -- view = (view . tagCoverageContainer) 164 -- instance Has (Maybe Databrary.Model.Release.Types.Release) TagCoverage where 165 -- view = (view . tagCoverageContainer) 166 -- instance Has (Id Container) TagCoverage where 167 -- view = (view . tagCoverageContainer) 168 -- instance Has ContainerRow TagCoverage where 169 -- view = (view . tagCoverageContainer)