1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Solr.Tag 3 ( termTags 4 ) where 5 6 import Control.Monad ((>=>)) 7 import qualified Data.Aeson.Types as JSON 8 import qualified Data.ByteString.Char8 as BSC 9 import Data.Maybe (fromMaybe) 10 import Data.Monoid ((<>)) 11 import qualified Data.Text.Encoding as TE 12 import qualified Network.HTTP.Client as HC 13 import Network.HTTP.Types.URI (renderSimpleQuery) 14 15 import Databrary.Ops 16 import Databrary.Has 17 import Databrary.Service.DB 18 import Databrary.HTTP.Client 19 import Databrary.Model.Tag 20 import Databrary.Solr.Service 21 22 parseTags :: JSON.Value -> JSON.Parser [TagName] 23 parseTags = JSON.withObject "terms" $ 24 (JSON..: "terms") >=> (JSON..: "tag_name") >=> tf where 25 tf [] = return [] 26 tf (JSON.String n:JSON.Number _c:l) = (TagName (TE.encodeUtf8 n) :) <$> tf l 27 tf _ = fail "mismatched terms" 28 29 termTags :: (MonadSolr c m, MonadDB c m) => Maybe TagName -> Int -> m [TagName] 30 termTags pre count = do 31 req <- peeks solrRequest 32 r <- focusIO $ httpRequestJSON req 33 { HC.path = HC.path req <> "terms" 34 , HC.queryString = renderSimpleQuery True $ 35 maybe id ((:) . (,) "terms.prefix" . tagNameBS) pre 36 [ ("terms.fl", "tag_name") 37 , ("terms.limit", BSC.pack $ show count) 38 ] 39 } 40 fromMaybeM (map tagName <$> findTags (fromMaybe (TagName "") pre) count) $ 41 JSON.parseMaybe parseTags =<< r