1 {-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds, 2 GeneralizedNewtypeDeriving, DeriveDataTypeable #-}module 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 Ops 22 import Has (Has(..)) 23 import qualified JSON 24 import Model.Kind 25 import Model.Id.Types 26 import Model.Party.Types 27 import Model.Container.Types 28 import Model.Segment 29 import Model.Slot.Types 30 import 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 instance Kinded Tag where 62 kindOf _ = "tag" 63 64 data TagUse = TagUse 65 { useTag :: Tag 66 , tagKeyword :: Bool 67 , tagWho :: Account 68 , tagSlot :: Slot 69 } 70 71 instance Has (Id Container) TagUse where 72 view = view . tagSlot 73 instance Has Model.Volume.Types.Volume TagUse where 74 view = view . tagSlot 75 instance Has (Id Model.Volume.Types.Volume) TagUse where 76 view = volumeId . volumeRow . containerVolume . slotContainer . tagSlot 77 78 data TagUseRow = TagUseRow 79 { useTagRow :: Tag 80 , tagRowKeyword :: Bool 81 , tagRowWhoId :: Id Party 82 , tagRowSlotId :: SlotId 83 } 84 85 data TagWeight = TagWeight 86 { tagWeightTag :: Tag 87 , tagWeightWeight :: Int32 88 } 89 90 data TagCoverage = TagCoverage 91 { tagCoverageWeight :: !TagWeight 92 , tagCoverageContainer :: Container 93 , tagCoverageSegments 94 , tagCoverageKeywords 95 , tagCoverageVotes :: [Segment] 96 }