module Solr.Document
( SolrDocument(..)
, SolrRecordMeasures(..)
, SolrSegment(..)
, metricField
) where
import qualified Data.Aeson as JSON
import qualified Data.Aeson.TH as JTH
import qualified Data.ByteString as BS
import Data.Char (isAlphaNum)
import Data.Int (Int16)
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import qualified Data.Text as T
import Model.Id.Types
import Model.Permission.Types
import Model.Release.Types
import Model.Party.Types
import Model.Volume.Types
import Model.Container.Types
import Model.Offset
import Model.Segment
import Model.Format.Types
import Model.Asset.Types
import Model.Time
import Model.Age
import Model.Record.Types
import Model.Category.Types
import Model.Metric
import Model.Tag.Types
import Model.Comment.Types
import StringUtil
safeField :: T.Text -> T.Text
safeField = T.map safeChar where
safeChar c
| isAlphaNum c = c
| otherwise = '_'
newtype SolrRecordMeasures = SolrRecordMeasures [(Metric, MeasureDatum)]
metricLabel :: Metric -> T.Text
metricLabel Metric{ metricType = MeasureTypeText, metricOptions = _:_ } = "enum"
metricLabel m@Metric{ metricType = MeasureTypeText }
| metricLong m = "long"
| otherwise = "text"
metricLabel Metric{ metricType = MeasureTypeNumeric } = "numeric"
metricLabel Metric{ metricType = MeasureTypeDate } = "date"
metricLabel Metric{ metricType = MeasureTypeVoid } = "void"
metricField :: Metric -> T.Text
metricField m = "record_" <> metricLabel m <> ('_' `T.cons` safeField (metricName m))
metricDatum :: Metric -> MeasureDatum -> JSON.Value
metricDatum Metric{ metricType = MeasureTypeDate } d = JSON.toJSON $ d <> "T12:00:00Z"
metricDatum Metric{ metricType = MeasureTypeVoid } _ = JSON.toJSON True
metricDatum _ d = JSON.toJSON d
measureKeyValue :: JSON.KeyValue kv => (Metric, MeasureDatum) -> kv
measureKeyValue (m, d) = metricField m JSON..= metricDatum m d
instance JSON.ToJSON SolrRecordMeasures where
toJSON (SolrRecordMeasures ms) =
JSON.object $ map measureKeyValue ms
toEncoding (SolrRecordMeasures ms) =
JSON.pairs $ foldr ((<>) . measureKeyValue) mempty ms
newtype SolrSegment = SolrSegment Segment deriving (JSON.FromJSON)
instance Show SolrSegment where
showsPrec _ (SolrSegment s) = showSegmentWith (shows . offsetMillis) s
instance JSON.ToJSON SolrSegment where
toJSON s = JSON.String $ T.pack $ show s
toEncoding s = JSON.toEncoding $ show s
data SolrDocument
= SolrParty
{ solrId :: !BS.ByteString
, solrPartyId :: Id Party
, solrPartySortName :: T.Text
, solrPartyPreName :: Maybe T.Text
, solrPartyAffiliation :: Maybe T.Text
, solrPartyIsInstitution :: Bool
, solrPartyAuthorization :: Maybe Permission
}
| SolrVolume
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrName :: Maybe T.Text
, solrBody :: Maybe T.Text
, solrVolumeOwnerIds :: [Id Party]
, solrVolumeOwnerNames :: [T.Text]
, solrCitation :: Maybe T.Text
, solrCitationYear :: Maybe Int16
}
| SolrContainer
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrName :: Maybe T.Text
, solrContainerTop :: Bool
, solrContainerDate :: Maybe MaskedDate
, solrRelease :: Maybe Release
}
| SolrAsset
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrSegment :: SolrSegment
, solrSegmentDuration :: Maybe Offset
, solrAssetId :: Id Asset
, solrName :: Maybe T.Text
, solrFormatId :: Id Format
, solrRelease :: Maybe Release
}
| SolrExcerpt
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrSegment :: SolrSegment
, solrSegmentDuration :: Maybe Offset
, solrAssetId :: Id Asset
, solrRelease :: Maybe Release
}
| SolrRecord
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrSegment :: SolrSegment
, solrSegmentDuration :: Maybe Offset
, solrRecordId :: Id Record
, solrRecordCategoryId :: Id Category
, solrRecordMeasures :: SolrRecordMeasures
, solrRecordAge :: Maybe Age
}
| SolrTagId
{ solrId :: !BS.ByteString
, solrTagId :: Id Tag
, solrTagName :: TagName
}
| SolrTag
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrSegment :: SolrSegment
, solrSegmentDuration :: Maybe Offset
, solrTagId :: Id Tag
, solrTagName :: TagName
, solrKeyword :: Maybe TagName
, solrPartyId :: Id Party
}
| SolrComment
{ solrId :: !BS.ByteString
, solrVolumeId :: Id Volume
, solrContainerId :: Id Container
, solrSegment :: SolrSegment
, solrSegmentDuration :: Maybe Offset
, solrCommentId :: Id Comment
, solrPartyId :: Id Party
, solrBody :: Maybe T.Text
}
$(return [])
solrToJSON :: SolrDocument -> JSON.Value
solrToJSON =
$(JTH.mkToJSON JTH.defaultOptions
{ JTH.fieldLabelModifier = \('s':'o':'l':'r':s) -> fromCamel s
, JTH.constructorTagModifier = \('S':'o':'l':'r':s) -> fromCamel s
, JTH.omitNothingFields = True
, JTH.sumEncoding = JTH.TaggedObject
{ JTH.tagFieldName = "content_type"
, JTH.contentsFieldName = error "solrToJSON: contentsFieldName"
}
} ''SolrDocument)
fixToJSON :: SolrDocument -> JSON.Value -> JSON.Value
fixToJSON SolrRecord{} (JSON.Object o) = JSON.Object $
maybe o (HM.union $ HM.delete k o) $ do
JSON.Object m <- HM.lookup k o
return m
where k = "record_measures"
fixToJSON _ j = j
instance JSON.ToJSON SolrDocument where
toJSON s = fixToJSON s $ solrToJSON s