{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Exhentai.API.Search
  ( SearchQuery (..),
    SearchResult (..),
    search,
    searchRecur,
    searchRecurResumable,
    fetchSearchPage,
  )
where

import Conduit
import Control.Effect
import Control.Effect.Bracket
import Control.Effect.Error
import Control.Effect.Exh
import Control.Monad
import Data.Maybe
import Data.Set (Set, toList, (\\))
import Data.String
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Client hiding (Cookie)
import Optics.Core
import Optics.TH
import Text.XML.Optics
import Web.Exhentai.API.Gallery
import Web.Exhentai.Parsing.Search
import Web.Exhentai.Utils
import Prelude hiding (last)

toBitField :: Set GalleryCategory -> Int
toBitField :: Set GalleryCategory -> Int
toBitField = [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> (Set GalleryCategory -> [Int]) -> Set GalleryCategory -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GalleryCategory -> Int) -> [GalleryCategory] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^) (Int -> Int) -> (GalleryCategory -> Int) -> GalleryCategory -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GalleryCategory -> Int
forall a. Enum a => a -> Int
fromEnum) ([GalleryCategory] -> [Int])
-> (Set GalleryCategory -> [GalleryCategory])
-> Set GalleryCategory
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set GalleryCategory -> [GalleryCategory]
forall a. Set a -> [a]
toList

data SearchQuery = SearchQuery
  { SearchQuery -> Maybe (Set GalleryCategory)
categories :: Maybe (Set GalleryCategory),
    SearchQuery -> Text
searchString :: {-# UNPACK #-} Text
  }
  deriving (Int -> SearchQuery -> ShowS
[SearchQuery] -> ShowS
SearchQuery -> String
(Int -> SearchQuery -> ShowS)
-> (SearchQuery -> String)
-> ([SearchQuery] -> ShowS)
-> Show SearchQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchQuery] -> ShowS
$cshowList :: [SearchQuery] -> ShowS
show :: SearchQuery -> String
$cshow :: SearchQuery -> String
showsPrec :: Int -> SearchQuery -> ShowS
$cshowsPrec :: Int -> SearchQuery -> ShowS
Show, SearchQuery -> SearchQuery -> Bool
(SearchQuery -> SearchQuery -> Bool)
-> (SearchQuery -> SearchQuery -> Bool) -> Eq SearchQuery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchQuery -> SearchQuery -> Bool
$c/= :: SearchQuery -> SearchQuery -> Bool
== :: SearchQuery -> SearchQuery -> Bool
$c== :: SearchQuery -> SearchQuery -> Bool
Eq)

queryArgCat :: Set GalleryCategory -> Int
queryArgCat :: Set GalleryCategory -> Int
queryArgCat Set GalleryCategory
s = Set GalleryCategory -> Int
toBitField (Set GalleryCategory -> Int) -> Set GalleryCategory -> Int
forall a b. (a -> b) -> a -> b
$ Set GalleryCategory
allGalleryCats Set GalleryCategory -> Set GalleryCategory -> Set GalleryCategory
forall a. Ord a => Set a -> Set a -> Set a
\\ Set GalleryCategory
s

data SearchResult = SearchResult
  { SearchResult -> [Gallery]
galleries :: [Gallery],
    SearchResult -> Maybe Text
prevPage :: Maybe Text,
    SearchResult -> Maybe Text
nextPage :: Maybe Text
  }
  deriving (Int -> SearchResult -> ShowS
[SearchResult] -> ShowS
SearchResult -> String
(Int -> SearchResult -> ShowS)
-> (SearchResult -> String)
-> ([SearchResult] -> ShowS)
-> Show SearchResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchResult] -> ShowS
$cshowList :: [SearchResult] -> ShowS
show :: SearchResult -> String
$cshow :: SearchResult -> String
showsPrec :: Int -> SearchResult -> ShowS
$cshowsPrec :: Int -> SearchResult -> ShowS
Show, SearchResult -> SearchResult -> Bool
(SearchResult -> SearchResult -> Bool)
-> (SearchResult -> SearchResult -> Bool) -> Eq SearchResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchResult -> SearchResult -> Bool
$c/= :: SearchResult -> SearchResult -> Bool
== :: SearchResult -> SearchResult -> Bool
$c== :: SearchResult -> SearchResult -> Bool
Eq)

parseSearchPage :: Document -> SearchResult
parseSearchPage :: Document -> SearchResult
parseSearchPage Document
d =
  let galleries :: [Gallery]
galleries = (Text -> Maybe Gallery) -> [Text] -> [Gallery]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Gallery
parseGalleryLink ([Text] -> [Gallery]) -> [Text] -> [Gallery]
forall a b. (a -> b) -> a -> b
$ Document
d Document
-> Optic A_Traversal '[] Element Element Text Text -> [Text]
forall l (is :: IxList) a.
(Is (Join A_Traversal l) A_Fold, Is l (Join A_Traversal l),
 Is A_Traversal (Join A_Traversal l)) =>
Document -> Optic l is Element Element a a -> [a]
^..: Traversal' Element Element
galleryPreviewElement Traversal' Element Element
-> Optic A_Traversal '[] Element Element Text Text
-> Optic A_Traversal '[] Element Element Text Text
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal '[] Element Element Text Text
galleryLink
      fld :: Traversal' Document Element
      fld :: Traversal' Document Element
fld = Traversal' Document Element
body Traversal' Document Element
-> Traversal' Element Element
-> Optic
     (Join (Join A_Traversal A_Traversal) A_Traversal)
     (Append '[] '[])
     Document
     Document
     Element
     Element
forall k l (is :: IxList) s t (js :: IxList) a b.
(Is (Join k A_Traversal) (Join (Join k A_Traversal) l),
 Is l (Join (Join k A_Traversal) l), Is k (Join k A_Traversal),
 Is A_Traversal (Join k A_Traversal)) =>
Optic k is s t Element Element
-> Optic l js Element Element a b
-> Optic (Join (Join k A_Traversal) l) (Append is js) s t a b
.// Traversal' Element Element
pagesElem
      prevPage :: Maybe Text
prevPage = do
        Element
first <- Traversal' Document Element -> Document -> Maybe Element
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf Traversal' Document Element
fld Document
d
        Element
first Element -> Optic' An_AffineFold '[] Element Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic A_Traversal '[] Element Element Text Text
-> Optic' An_AffineFold '[] Element Text
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre Optic A_Traversal '[] Element Element Text Text
linkOf
      nextPage :: Maybe Text
nextPage = do
        Element
last <- Traversal' Document Element -> Document -> Maybe Element
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
lastOf Traversal' Document Element
fld Document
d
        Element
last Element -> Optic' An_AffineFold '[] Element Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic A_Traversal '[] Element Element Text Text
-> Optic' An_AffineFold '[] Element Text
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre Optic A_Traversal '[] Element Element Text Text
linkOf
   in SearchResult :: [Gallery] -> Maybe Text -> Maybe Text -> SearchResult
SearchResult {[Gallery]
Maybe Text
nextPage :: Maybe Text
prevPage :: Maybe Text
galleries :: [Gallery]
$sel:nextPage:SearchResult :: Maybe Text
$sel:prevPage:SearchResult :: Maybe Text
$sel:galleries:SearchResult :: [Gallery]
..}

-- | Fetch a search page using a 'Request'
fetchSearchPage' ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  Request ->
  m SearchResult
fetchSearchPage' :: Request -> m SearchResult
fetchSearchPage' Request
req = do
  Document
d <- Request -> m Document
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Request -> m Document
htmlRequest Request
req
  SearchResult -> m SearchResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SearchResult -> m SearchResult) -> SearchResult -> m SearchResult
forall a b. (a -> b) -> a -> b
$ Document -> SearchResult
parseSearchPage Document
d
{-# INLINEABLE fetchSearchPage' #-}

-- | Fetch a search page using its url
fetchSearchPage ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  Text ->
  m SearchResult
fetchSearchPage :: Text -> m SearchResult
fetchSearchPage = Request -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Request -> m SearchResult
fetchSearchPage' (Request -> m SearchResult)
-> (Text -> m Request) -> Text -> m SearchResult
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> m Request
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
String -> m Request
formRequest (String -> m Request) -> (Text -> String) -> Text -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
{-# INLINEABLE fetchSearchPage #-}

-- | Search a search query
search ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  SearchQuery ->
  m SearchResult
search :: SearchQuery -> m SearchResult
search SearchQuery {Maybe (Set GalleryCategory)
Text
searchString :: Text
categories :: Maybe (Set GalleryCategory)
$sel:searchString:SearchQuery :: SearchQuery -> Text
$sel:categories:SearchQuery :: SearchQuery -> Maybe (Set GalleryCategory)
..} = do
  let catQ :: [(ByteString, Maybe ByteString)]
catQ = [(ByteString, Maybe ByteString)]
-> (Set GalleryCategory -> [(ByteString, Maybe ByteString)])
-> Maybe (Set GalleryCategory)
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Set GalleryCategory
c -> [(ByteString
"f_cats", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Set GalleryCategory -> Int
queryArgCat Set GalleryCategory
c)]) Maybe (Set GalleryCategory)
categories
  Request
initReq <- String -> m Request
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
String -> m Request
formRequest String
"https://exhentai.org"
  let req :: Request
req =
        [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString
          ( [(ByteString, Maybe ByteString)]
catQ
              [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. [a] -> [a] -> [a]
++ [ (ByteString
"f_search", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
searchString)
                 ]
          )
          Request
initReq
  Request -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Request -> m SearchResult
fetchSearchPage' Request
req
{-# INLINEABLE search #-}

-- | Iterate through all the Galleries asosciated with a search query, putting them into a stream
searchRecur ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  SearchQuery ->
  ConduitT i Gallery m ()
searchRecur :: SearchQuery -> ConduitT i Gallery m ()
searchRecur SearchQuery
q = do
  SearchResult {[Gallery]
Maybe Text
nextPage :: Maybe Text
prevPage :: Maybe Text
galleries :: [Gallery]
$sel:nextPage:SearchResult :: SearchResult -> Maybe Text
$sel:prevPage:SearchResult :: SearchResult -> Maybe Text
$sel:galleries:SearchResult :: SearchResult -> [Gallery]
..} <- m SearchResult -> ConduitT i Gallery m SearchResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SearchResult -> ConduitT i Gallery m SearchResult)
-> m SearchResult -> ConduitT i Gallery m SearchResult
forall a b. (a -> b) -> a -> b
$ SearchQuery -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
SearchQuery -> m SearchResult
search SearchQuery
q
  [Gallery] -> ConduitT i (Element [Gallery]) m ()
forall (m :: Type -> Type) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [Gallery]
galleries
  case Maybe Text
nextPage of
    Maybe Text
Nothing -> () -> ConduitT i Gallery m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just Text
url -> Text -> ConduitT i Gallery m ()
forall (m :: Type -> Type) i.
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> ConduitT i Gallery m ()
searchRecur' Text
url
{-# INLINEABLE searchRecur #-}

searchRecur' ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  -- | url
  Text ->
  ConduitT i Gallery m ()
searchRecur' :: Text -> ConduitT i Gallery m ()
searchRecur' Text
url = do
  SearchResult {[Gallery]
Maybe Text
nextPage :: Maybe Text
prevPage :: Maybe Text
galleries :: [Gallery]
$sel:nextPage:SearchResult :: SearchResult -> Maybe Text
$sel:prevPage:SearchResult :: SearchResult -> Maybe Text
$sel:galleries:SearchResult :: SearchResult -> [Gallery]
..} <- m SearchResult -> ConduitT i Gallery m SearchResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SearchResult -> ConduitT i Gallery m SearchResult)
-> m SearchResult -> ConduitT i Gallery m SearchResult
forall a b. (a -> b) -> a -> b
$ Text -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> m SearchResult
fetchSearchPage Text
url
  [Gallery] -> ConduitT i (Element [Gallery]) m ()
forall (m :: Type -> Type) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [Gallery]
galleries
  case Maybe Text
nextPage of
    Maybe Text
Nothing -> () -> ConduitT i Gallery m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just Text
url' -> Text -> ConduitT i Gallery m ()
forall (m :: Type -> Type) i.
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> ConduitT i Gallery m ()
searchRecur' Text
url'
{-# INLINEABLE searchRecur' #-}

-- | A resumable version of 'searchRecur' that reports it's progress.
searchRecurResumable ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  SearchQuery ->
  ConduitT i (Either Text Gallery) m ()
searchRecurResumable :: SearchQuery -> ConduitT i (Either Text Gallery) m ()
searchRecurResumable SearchQuery
q = do
  SearchResult {[Gallery]
Maybe Text
nextPage :: Maybe Text
prevPage :: Maybe Text
galleries :: [Gallery]
$sel:nextPage:SearchResult :: SearchResult -> Maybe Text
$sel:prevPage:SearchResult :: SearchResult -> Maybe Text
$sel:galleries:SearchResult :: SearchResult -> [Gallery]
..} <- m SearchResult -> ConduitT i (Either Text Gallery) m SearchResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SearchResult -> ConduitT i (Either Text Gallery) m SearchResult)
-> m SearchResult
-> ConduitT i (Either Text Gallery) m SearchResult
forall a b. (a -> b) -> a -> b
$ SearchQuery -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
SearchQuery -> m SearchResult
search SearchQuery
q
  [Either Text Gallery]
-> ConduitT i (Element [Either Text Gallery]) m ()
forall (m :: Type -> Type) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany ([Either Text Gallery]
 -> ConduitT i (Element [Either Text Gallery]) m ())
-> [Either Text Gallery]
-> ConduitT i (Element [Either Text Gallery]) m ()
forall a b. (a -> b) -> a -> b
$ (Gallery -> Either Text Gallery)
-> [Gallery] -> [Either Text Gallery]
forall a b. (a -> b) -> [a] -> [b]
map Gallery -> Either Text Gallery
forall a b. b -> Either a b
Right [Gallery]
galleries
  case Maybe Text
nextPage of
    Maybe Text
Nothing -> () -> ConduitT i (Either Text Gallery) m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just Text
url -> Text -> ConduitT i (Either Text Gallery) m ()
forall (m :: Type -> Type) i.
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> ConduitT i (Either Text Gallery) m ()
searchRecurResumable' Text
url
{-# INLINEABLE searchRecurResumable #-}

searchRecurResumable' ::
  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
  -- | url
  Text ->
  ConduitT i (Either Text Gallery) m ()
searchRecurResumable' :: Text -> ConduitT i (Either Text Gallery) m ()
searchRecurResumable' Text
url = do
  Either Text Gallery -> ConduitT i (Either Text Gallery) m ()
forall (m :: Type -> Type) o i. Monad m => o -> ConduitT i o m ()
yield (Either Text Gallery -> ConduitT i (Either Text Gallery) m ())
-> Either Text Gallery -> ConduitT i (Either Text Gallery) m ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Gallery
forall a b. a -> Either a b
Left Text
url
  SearchResult {[Gallery]
Maybe Text
nextPage :: Maybe Text
prevPage :: Maybe Text
galleries :: [Gallery]
$sel:nextPage:SearchResult :: SearchResult -> Maybe Text
$sel:prevPage:SearchResult :: SearchResult -> Maybe Text
$sel:galleries:SearchResult :: SearchResult -> [Gallery]
..} <- m SearchResult -> ConduitT i (Either Text Gallery) m SearchResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SearchResult -> ConduitT i (Either Text Gallery) m SearchResult)
-> m SearchResult
-> ConduitT i (Either Text Gallery) m SearchResult
forall a b. (a -> b) -> a -> b
$ Text -> m SearchResult
forall (m :: Type -> Type).
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> m SearchResult
fetchSearchPage Text
url
  [Either Text Gallery]
-> ConduitT i (Element [Either Text Gallery]) m ()
forall (m :: Type -> Type) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany ([Either Text Gallery]
 -> ConduitT i (Element [Either Text Gallery]) m ())
-> [Either Text Gallery]
-> ConduitT i (Element [Either Text Gallery]) m ()
forall a b. (a -> b) -> a -> b
$ (Gallery -> Either Text Gallery)
-> [Gallery] -> [Either Text Gallery]
forall a b. (a -> b) -> [a] -> [b]
map Gallery -> Either Text Gallery
forall a b. b -> Either a b
Right [Gallery]
galleries
  case Maybe Text
nextPage of
    Maybe Text
Nothing -> () -> ConduitT i (Either Text Gallery) m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just Text
url' -> Text -> ConduitT i (Either Text Gallery) m ()
forall (m :: Type -> Type) i.
Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>
Text -> ConduitT i (Either Text Gallery) m ()
searchRecurResumable' Text
url'
{-# INLINEABLE searchRecurResumable' #-}

makeFieldLabelsWith noPrefixFieldLabels ''SearchQuery
makeFieldLabelsWith noPrefixFieldLabels ''SearchResult