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