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)