1 {-# LANGUAGE OverloadedStrings #-} 2 module 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 Ops 16 import Has 17 import Service.DB 18 import HTTP.Client 19 import Model.Tag 20 import 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