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   }