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