exh 0.2.0 → 1.0.0

raw patch · 20 files changed

+970/−739 lines, 20 filesdep +in-other-wordsdep +language-javascriptdep +optics-coredep −exceptionsdep −http-conduitdep −lensdep ~http-client-tlsdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: in-other-words, language-javascript, optics-core, optics-th, xml-optics

Dependencies removed: exceptions, http-conduit, lens, monad-control, monad-time, mtl, quickjs-hs, retry, transformers-base, xml-lens

Dependency ranges changed: http-client-tls, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• exh.cabal +24/−29
• src/Control/Effect/Exh.hs +195/−0
• src/Language/JavaScript/Extraction.hs +155/−0
• src/Web/Exhentai.hs +36/−1
• src/Web/Exhentai/API/Archiver.hs +30/−21
• src/Web/Exhentai/API/Auth.hs +19/−9
• src/Web/Exhentai/API/Gallery.hs +199/−29
• src/Web/Exhentai/API/MPV.hs +85/−41
• src/Web/Exhentai/API/Search.hs +58/−27
• src/Web/Exhentai/API/Watched.hs +14/−6
• src/Web/Exhentai/Errors.hs +2/−3
• src/Web/Exhentai/Parsing/Gallery.hs +59/−72
• src/Web/Exhentai/Parsing/Image.hs +8/−5
• src/Web/Exhentai/Parsing/MPV.hs +0/−55
• src/Web/Exhentai/Parsing/Search.hs +18/−14
• src/Web/Exhentai/Types.hs +0/−187
• src/Web/Exhentai/Types/CookieT.hs +0/−180
• src/Web/Exhentai/Utils.hs +61/−36
• test/Spec.hs +3/−24

@@ -8,3 +8,7 @@  - Bug fixes - Add a resumable variant of the search function++## 1.0.0++- Rewrite using in-other-words

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            exh-version:         0.2.0+version:         1.0.0 synopsis:        A library for crawling exhentai description:   A library for crawling exhentai, with the support of streaming@@ -11,7 +11,7 @@ author:          Poscat maintainer:      Poscat <poscat@mail.poscat.moe> copyright:       Copyright (c) Poscat 2021-stability:       alpha+stability:       experimental homepage:        https://github.com/poscat0x04/exh bug-reports:     https://github.com/poscat0x04/exh/issues extra-doc-files:@@ -20,29 +20,23 @@  common common-attrs   build-depends:-    , aeson              >=1.4.7   && <1.6-    , base               >=4.10    && <5-    , bytestring         >=0.10.12 && <0.12-    , conduit            ^>=1.3.4-    , containers         ^>=0.6.2-    , exceptions         ^>=0.10.4-    , html-conduit       ^>=1.3.2-    , http-client        >=0.6.4   && <0.8-    , http-client-tls    ^>=0.3.5-    , http-conduit       ^>=2.3.7-    , lens               ^>=4.19-    , megaparsec         ^>=9.0-    , monad-control      ^>=1.0.2-    , monad-time         ^>=0.3-    , mtl                ^>=2.2-    , quickjs-hs         ^>=0.1.2.4-    , retry              ^>=0.8.1-    , text               ^>=1.2.3-    , time               >=1.9.3   && <1.12-    , transformers       ^>=0.5.6-    , transformers-base  ^>=0.4.5-    , xml-conduit        >=1.8.0   && <1.10-    , xml-lens           >=0.2     && <0.3+    , aeson                >=1.4.7   && <1.6+    , base                 >=4.10    && <5+    , bytestring           >=0.10.12 && <0.12+    , conduit              ^>=1.3.4+    , containers           ^>=0.6.2+    , html-conduit         ^>=1.3.2+    , http-client          >=0.6.4   && <0.8+    , in-other-words+    , language-javascript+    , megaparsec           ^>=9.0+    , optics-core+    , optics-th+    , text                 ^>=1.2.3+    , time                 >=1.9.3   && <1.12+    , transformers+    , xml-conduit          >=1.8.0   && <1.10+    , xml-optics    default-language:   Haskell2010   default-extensions:@@ -86,16 +80,16 @@     Web.Exhentai.API.MPV     Web.Exhentai.API.Search     Web.Exhentai.API.Watched-    Web.Exhentai.Errors     Web.Exhentai.Parsing.Gallery     Web.Exhentai.Parsing.Image-    Web.Exhentai.Parsing.MPV     Web.Exhentai.Parsing.Search-    Web.Exhentai.Types-    Web.Exhentai.Types.CookieT     Web.Exhentai.Utils    other-modules:+    Control.Effect.Exh+    Language.JavaScript.Extraction+    Web.Exhentai.Errors+   hs-source-dirs:  src  test-suite exh-test@@ -104,6 +98,7 @@   build-depends:     , exh     , hspec+    , http-client-tls    hs-source-dirs: test   main-is:        Spec.hs

@@ -0,0 +1,195 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Internal module+module Control.Effect.Exh where++import Conduit+import Control.Concurrent+  ( MVar,+    newMVar,+    putMVar,+    readMVar,+    takeMVar,+  )+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Reader+import Control.Monad+import Control.Monad.Trans.Cont+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Network.HTTP.Client hiding (Cookie)+import Network.HTTP.Client.MultipartFormData++data Http :: Effect where+  FormRequest :: String -> Http m Request+  GenBoundary :: Http m ByteString+  RespOpen :: Request -> Http m (Response BodyReader)+  RespClose :: Response a -> Http m ()++formRequest :: Effs '[Http, Error HttpException] m => String -> m Request+formRequest = send . FormRequest+{-# INLINE formRequest #-}++genBoundary :: Eff Http m => m ByteString+genBoundary = send GenBoundary+{-# INLINE genBoundary #-}++respOpen :: Effs '[Http, Error HttpException] m => Request -> m (Response BodyReader)+respOpen = send . RespOpen+{-# INLINE respOpen #-}++respClose :: Eff Http m => Response a -> m ()+respClose = send . RespClose+{-# INLINE respClose #-}++data HttpH++instance (Effs '[Embed IO, Reader Manager] m) => Handler HttpH Http m where+  effHandler (FormRequest s) = embed @IO $ parseRequest s+  effHandler GenBoundary = embed webkitBoundary+  effHandler (RespOpen req) = ask >>= embed . responseOpen req+  effHandler (RespClose resp) = embed $ responseClose resp+  {-# INLINEABLE effHandler #-}++type HttpToIOC = InterpretC HttpH Http++httpToIO :: (Effs '[Embed IO, Reader Manager] m, Threaders '[ReaderThreads] m p) => HttpToIOC m a -> m a+httpToIO = interpretViaHandler+{-# INLINE httpToIO #-}++--------------------------------------------------+--++data Cookie :: Effect where+  TakeCookie :: Cookie m CookieJar+  ReadCookie :: Cookie m CookieJar+  PutCookie :: CookieJar -> Cookie m ()++takeCookie :: Eff Cookie m => m CookieJar+takeCookie = send TakeCookie+{-# INLINE takeCookie #-}++readCookie :: Eff Cookie m => m CookieJar+readCookie = send ReadCookie+{-# INLINE readCookie #-}++putCookie :: Eff Cookie m => CookieJar -> m ()+putCookie = send . PutCookie+{-# INLINE putCookie #-}++data CookieH++instance Effs '[Reader (MVar CookieJar), Embed IO] m => Handler CookieH Cookie m where+  effHandler TakeCookie = ask >>= embed . takeMVar+  effHandler ReadCookie = ask >>= embed . readMVar+  effHandler (PutCookie c) = do+    ref <- ask+    embed $ putMVar ref c+  {-# INLINEABLE effHandler #-}++type CookieToReaderC = InterpretC CookieH Cookie++type CookieToIOC = CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)]++cookieToIO :: (Eff (Embed IO) m, Threaders '[ReaderThreads] m p) => CookieToIOC m a -> m a+cookieToIO m = do+  ref <- embed $ newMVar mempty+  runReader ref $+    interpretViaHandler $+      runComposition m+{-# INLINE cookieToIO #-}++--------------------------------------------------+--++data ConduitIO :: Effect where+  RunConduitIO :: ConduitT () Void IO a -> ConduitIO m a++runConduitIO :: Eff ConduitIO m => ConduitT () Void IO a -> m a+runConduitIO = send . RunConduitIO+{-# INLINE runConduitIO #-}++data ConduitIOH++instance Eff (Embed IO) m => Handler ConduitIOH ConduitIO m where+  effHandler (RunConduitIO c) = embed $ runConduit c+  {-# INLINEABLE effHandler #-}++type ConduitIOToIOC = InterpretC ConduitIOH ConduitIO++conduitIOToIO :: Eff (Embed IO) m => ConduitIOToIOC m a -> m a+conduitIOToIO = interpretViaHandler+{-# INLINE conduitIOToIO #-}++--------------------------------------------------+--++type ExhC = CompositionC '[HttpToIOC, ConduitIOToIOC, CookieToIOC]++exhToIO :: (Effs '[Embed IO, Reader Manager] m, Threaders '[ReaderThreads] m p) => ExhC m a -> m a+exhToIO m =+  cookieToIO $+    conduitIOToIO $+      httpToIO $+        runComposition m+{-# INLINE exhToIO #-}++--------------------------------------------------+--++attachFormData :: Eff Http m => [PartM m] -> Request -> m Request+attachFormData parts req = do+  boundary <- genBoundary+  formDataBodyWithBoundary boundary parts req++bodyReaderSource :: BodyReader -> ConduitT i ByteString IO ()+bodyReaderSource br = loop+  where+    loop = do+      bs <- lift br+      unless (B.null bs) $ do+        yield bs+        loop++resetCookie :: Eff Cookie m => m ()+resetCookie = takeCookie >> putCookie mempty+{-# INLINEABLE resetCookie #-}++modifyJar ::+  Effs '[Http, Cookie, Error HttpException, Bracket] m =>+  Request ->+  m ()+modifyJar req =+  bracketOnError+    takeCookie+    putCookie+    $ \jar -> do+      let req' = req {cookieJar = Just jar}+      bracket+        (respOpen req')+        respClose+        (putCookie . responseCookieJar)+{-# INLINEABLE modifyJar #-}++openWithJar ::+  Effs '[Http, Cookie, Error HttpException] m => Request -> m (Response (ConduitT i ByteString IO ()))+openWithJar req = do+  jar <- readCookie+  resp <- respOpen (req {cookieJar = Just jar})+  pure $ fmap bodyReaderSource resp++withSource ::+  Effs '[Http, Cookie, Error HttpException, Bracket] m =>+  Request ->+  ContT r m (Response (ConduitT i ByteString IO ()))+withSource req = ContT $ \k -> do+  jar <- readCookie+  bracket+    (respOpen (req {cookieJar = Just jar}))+    respClose+    (k . fmap bodyReaderSource)+{-# INLINEABLE withSource #-}

@@ -0,0 +1,155 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Internal module. Extract values from mpv script+module Language.JavaScript.Extraction where++import Data.Aeson+import Data.ByteString.Lazy.Char8 (pack)+import Data.Maybe+import Data.Text (Text)+import Language.JavaScript.Parser.AST+import Optics.TH+import Text.Read+import Web.Exhentai.Utils hiding (div)+import Prelude hiding ((!!))++data MpvImage = MpvImage+  { name :: {-# UNPACK #-} Text,+    key :: {-# UNPACK #-} Text,+    thumbnail :: {-# UNPACK #-} Text+  }+  deriving (Show, Eq)++instance FromJSON MpvImage where+  parseJSON = withObject "mpv image" $ \o ->+    MpvImage+      <$> o .: "n"+      <*> o .: "k"+      <*> o .: "t"++-- | All the variables defined in the scripts that came with the MPV+data Vars = Vars+  { gid :: {-# UNPACK #-} Int,+    mpvkey :: {-# UNPACK #-} Text,+    pageCount :: {-# UNPACK #-} Int,+    imageList :: [MpvImage]+  }+  deriving (Show, Eq)++class As a b where+  as :: a -> Maybe b++instance As JSExpression Int where+  as (JSDecimal _ s) = decode (pack s)+  as (JSExpressionBinary expr1 op expr2) = do+    i1 <- as expr1+    i2 <- as expr2+    case op of+      JSBinOpPlus {} -> pure $ i1 + i2+      JSBinOpMinus {} -> pure $ i1 - i2+      JSBinOpTimes {} -> pure $ i1 * i2+      JSBinOpDivide {} -> pure $ i1 `div` i2+      _ -> Nothing+  as (JSUnaryExpression op expr) = do+    i <- as expr+    case op of+      JSUnaryOpIncr {} -> pure $ i + 1+      JSUnaryOpDecr {} -> pure $ i - 1+      JSUnaryOpMinus {} -> pure $ - i+      JSUnaryOpPlus {} -> pure i+      _ -> Nothing+  as (JSVarInitExpression _ initializer) = as initializer+  as _ = Nothing++instance As JSExpression a => As JSVarInitializer a where+  as (JSVarInit _ expr) = as expr+  as _ = Nothing++instance As (JSCommaList JSExpression) a => As JSStatement a where+  as (JSVariable _ l _) = as l+  as _ = Nothing++instance {-# OVERLAPPABLE #-} As a b => As (JSCommaList a) b where+  as (JSLOne x) = as x+  as (JSLCons _ _ x) = as x+  as _ = Nothing++instance As JSExpression Text where+  as (JSStringLiteral _ s) = decode (pack s)+  as (JSVarInitExpression _ initializer) = as initializer+  as _ = Nothing++instance As JSPropertyName Text where+  as (JSPropertyString _ s) = readMaybe s+  as _ = Nothing++instance As JSArrayElement a => As JSExpression [a] where+  as (JSArrayLiteral _ l _) = Just $ mapMaybe as l+  as (JSVarInitExpression _ initializer) = as initializer+  as _ = Nothing++instance As JSExpression a => As JSArrayElement a where+  as (JSArrayElement expr) = as expr+  as (JSArrayComma _) = Nothing++class AsPair a where+  asPair :: a -> Maybe (Text, Text)++instance AsPair JSObjectProperty where+  asPair (JSPropertyNameandValue n _ [expr]) = (,) <$> as n <*> as expr+  asPair _ = Nothing++instance As (JSCommaList JSObjectProperty) [(Text, Text)] where+  as (JSLCons xs _ p) = (:) <$> asPair p <*> as xs+  as (JSLOne p) = pure <$> asPair p+  as JSLNil = pure []++instance {-# OVERLAPPABLE #-} As (JSCommaList a) b => As (JSCommaTrailingList a) b where+  as (JSCTLComma l _) = as l+  as (JSCTLNone l) = as l++instance As JSObjectPropertyList MpvImage where+  as l = do+    mapping <- (as l :: Maybe [(Text, Text)])+    thumbnail <- lookup "t" mapping+    key <- lookup "k" mapping+    name <- lookup "n" mapping+    pure MpvImage {..}++instance As JSExpression MpvImage where+  as (JSObjectLiteral _ l _) = as l+  as _ = Nothing++instance As JSAST Vars where+  as (JSAstProgram stmts _) = do+    gidStmt <- stmts !! 1+    gid <- as gidStmt+    imgStmt <- stmts !! 3+    imageList <- as imgStmt+    keyStmt <- stmts !! 2+    mpvkey <- as keyStmt+    pgCountStmt <- stmts !! 9+    pageCount <- as pgCountStmt+    pure Vars {..}+  as _ = Nothing++makeFieldLabelsWith noPrefixFieldLabels ''Vars+makeFieldLabelsWith noPrefixFieldLabels ''MpvImage++{-+extractEnv :: Text -> IO (Result Vars)+extractEnv script = quickjs $ do+  eval_ $ encodeUtf8 script+  gid' <- eval "gid"+  mpvkey' <- eval "mpvkey"+  imageList' <- eval "imagelist"+  pageCount' <- eval "pagecount"+  pure $ do+    gid <- fromJSON gid'+    mpvkey <- fromJSON mpvkey'+    imageList <- fromJSON imageList'+    pageCount <- fromJSON pageCount'+    pure Vars {..}+-}

@@ -1,5 +1,35 @@ module Web.Exhentai-  ( -- ** Authentication+  ( -- * Effects and effect interpreters++    -- ** Important+    Http,+    formRequest,+    genBoundary,+    respOpen,+    respClose,+    ConduitIO (..),+    runConduitIO,+    Cookie (..),+    takeCookie,+    readCookie,+    putCookie,+    ExhC,+    exhToIO,++    -- ** Unimportant+    HttpH,+    HttpToIOC,+    httpToIO,+    CookieH,+    CookieToIOC,+    cookieToIO,+    ConduitIOH,+    ConduitIOToIOC,+    conduitIOToIO,++    -- * API++    -- ** Authentication     module Au,      -- ** Getting information about galleries@@ -16,12 +46,17 @@      -- ** Fetching archives     module Ar,++    -- * Errors+    ExhentaiError (..),   ) where +import Control.Effect.Exh import Web.Exhentai.API.Archiver as Ar import Web.Exhentai.API.Auth as Au import Web.Exhentai.API.Gallery as G import Web.Exhentai.API.MPV as M import Web.Exhentai.API.Search as S import Web.Exhentai.API.Watched as W+import Web.Exhentai.Errors

@@ -5,64 +5,73 @@ where  import Conduit-import Control.Lens (Traversal')-import Control.Monad.Catch-import Control.Monad.Cont+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh+import Control.Monad.Trans.Cont import Data.ByteString (ByteString) import Data.Text (Text, unpack)-import Network.HTTP.Client.Conduit+import Network.HTTP.Client hiding (Cookie) import Network.HTTP.Client.MultipartFormData-import Text.XML.Lens+import Optics.Core (Traversal')+import Text.XML.Optics import Web.Exhentai.Errors-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils import Prelude hiding (id)  downloadLink :: Traversal' Element Text-downloadLink = id "db" ... id "continue" ... attr "href"+downloadLink = id "db" .// id "continue" .// attr "href"+{-# INLINE downloadLink #-} -originalParts :: [Part]+originalParts :: Applicative m => [PartM m] originalParts =   [ partBS "dltype" "org",     partBS "dlcheck" "Download Original Archive"   ] {-# INLINE originalParts #-} -resampledParts :: [Part]+resampledParts :: Applicative m => [PartM m] resampledParts =   [ partBS "dltype" "res",     partBS "dlcheck" "Download Resample Archive"   ] {-# INLINE resampledParts #-} -streamWith :: (MonadHttpState m, MonadIO n) => [Part] -> Text -> ContT r m (Response (ConduitT i ByteString n ()))+streamWith ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  [PartM m] ->+  Text ->+  ContT r m (Response (ConduitT i ByteString IO ())) streamWith parts url = ContT $ \k -> do   initReq <- formRequest $ unpack url-  req <- formDataBody parts initReq+  req <- attachFormData parts initReq   d <- htmlRequest req   case d ^?: downloadLink of-    Nothing -> throwM $ XMLParseFailure "download link" url+    Nothing -> throw $ XMLParseFailure "download link" url     Just l -> do       newReq <- formRequest $ unpack l       let req' = setQueryString [("start", Just "1")] newReq-      retryWhenTimeout $-        bracket-          (respOpen req')-          respClose-          k+      bracket+        (respOpen req')+        respClose+        (k . fmap bodyReaderSource)+{-# INLINEABLE streamWith #-}  -- | Download an origian archive from an archiver url as a stream streamOriginal ::-  (MonadHttpState m, MonadIO n) =>+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>   -- | Archiver url, usually the 'archiverLink` field   Text ->-  ContT r m (Response (ConduitT i ByteString n ()))+  ContT r m (Response (ConduitT i ByteString IO ())) streamOriginal = streamWith originalParts+{-# INLINEABLE streamOriginal #-}  -- | Download an resampled archive from an archiver url as a stream streamResampled ::-  (MonadHttpState m, MonadIO n) =>+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>   -- | Archiver url, usually the 'archiverLink` field   Text ->-  ContT r m (Response (ConduitT i ByteString n ()))+  ContT r m (Response (ConduitT i ByteString IO ())) streamResampled = streamWith resampledParts+{-# INLINEABLE streamResampled #-}

@@ -1,24 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Authentication API. module Web.Exhentai.API.Auth   ( Credential (..),     auth,   ) where +import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh import Data.ByteString (ByteString)-import GHC.Generics-import Network.HTTP.Client.Conduit+import Network.HTTP.Client hiding (Cookie) import Network.HTTP.Client.MultipartFormData-import Web.Exhentai.Types.CookieT+import Optics.TH  data Credential = Credential   { username :: ByteString,     password :: ByteString   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  -- | Authenticates and loads user preferences. -- This should be called before any other functions are called-auth :: MonadHttpState m => Credential -> m ()+auth :: Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket] m => Credential -> m () auth Credential {..} = do   initReq <- formRequest "POST https://forums.e-hentai.org/index.php"   let parts =@@ -36,10 +43,13 @@           ]           initReq   finalReq <- attachFormData parts req-  modifyingJar finalReq+  modifyJar finalReq   req2 <- formRequest "https://exhentai.org"-  modifyingJar req2+  modifyJar req2   req3 <- formRequest "https://exhentai.org/uconfig.php"-  modifyingJar req3+  modifyJar req3   req4 <- formRequest "https://exhentai.org/mytags"-  modifyingJar req4+  modifyJar req4+{-# INLINEABLE auth #-}++makeFieldLabelsWith noPrefixFieldLabels ''Credential

@@ -1,41 +1,133 @@ {-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} +-- | Gallery API. module Web.Exhentai.API.Gallery-  ( GalleryInfo (..),+  ( Gallery (..),+    GalleryInfo (..),     Visibility (..),+    GalleryCategory (..),+    TagCategory (..),+    allGalleryCats,     fetchGalleryInfo,++    -- ** Internal API+    parseGalleryLink,     parseGallery,   ) where -import Control.Lens ((^..), (^?))+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh import Control.Monad-import Control.Monad.Catch-import Data.Coerce-import Data.Text (Text, strip)+import Data.Maybe+import Data.Set (Set, fromList)+import Data.Text (Text, pack, strip) import Data.Time-import GHC.Generics+import Data.Void+import Network.HTTP.Client hiding (Cookie)+import Optics.Core+import Optics.TH+import Text.Megaparsec hiding (token)+import Text.Megaparsec.Char.Lexer import Text.XML-import Text.XML.Lens+import Text.XML.Optics import Web.Exhentai.Errors import qualified Web.Exhentai.Parsing.Gallery as G-import Web.Exhentai.Types-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils import Prelude hiding (length) import qualified Prelude as P +data Gallery = Gallery+  { galleryId :: {-# UNPACK #-} !Int,+    token :: {-# UNPACK #-} !Text+  }+  deriving (Show, Eq)++toGalleryLink :: Gallery -> Text+toGalleryLink Gallery {..} = "https://exhentai.org/g/" <> pack (show galleryId) <> "/" <> token <> "/"++parseGalleryLink :: Text -> Maybe Gallery+parseGalleryLink = parseMaybe galleryLink+  where+    galleryLink :: Parser Gallery+    galleryLink = do+      _ <- chunk "https://exhentai.org/g/"+      galleryId <- decimal+      _ <- single '/'+      token <- takeWhile1P Nothing (/= '/')+      _ <- optional $ single '/'+      pure Gallery {..}++data TagCategory+  = Language+  | Parody+  | Character+  | Group+  | Artist+  | Male+  | Female+  | Misc'+  | Reclass+  deriving (Show, Eq, Enum)++readTagCat :: Text -> Maybe TagCategory+readTagCat "language:" = Just Language+readTagCat "parody:" = Just Parody+readTagCat "character:" = Just Character+readTagCat "group:" = Just Group+readTagCat "artist:" = Just Artist+readTagCat "male:" = Just Male+readTagCat "female:" = Just Female+readTagCat "misc:" = Just Misc'+readTagCat "reclass:" = Just Reclass+readTagCat _ = Nothing++data GalleryCategory+  = Misc+  | Doujinshi+  | Manga+  | ArtistCG+  | GameCG+  | ImageSet+  | Cosplay+  | AsianPorn+  | NonH+  | Western+  | Private+  deriving (Show, Eq, Ord, Enum, Bounded)++allGalleryCats :: Set GalleryCategory+allGalleryCats = fromList [Misc .. Private]++readCat :: Text -> Maybe GalleryCategory+readCat "Doujinshi" = Just Doujinshi+readCat "Manga" = Just Manga+readCat "Artist CG" = Just ArtistCG+readCat "Game CG" = Just GameCG+readCat "Non-H" = Just NonH+readCat "Image Set" = Just ImageSet+readCat "Western" = Just Western+readCat "Cosplay" = Just Cosplay+readCat "Misc" = Just Misc+readCat "Private" = Just Private+readCat "Asian Porn" = Just AsianPorn+readCat _ = Nothing+ -- | Information about a gallery data GalleryInfo = GalleryInfo   { title :: {-# UNPACK #-} Text,     previewLink :: {-# UNPACK #-} Text,-    category :: GalleryCat,+    category :: GalleryCategory,     jaTitle :: Maybe Text,     uploader :: {-# UNPACK #-} Text,-    rating :: {-# UNPACK #-} Float,+    rating :: {-# UNPACK #-} Double,     ratingCount :: {-# UNPACK #-} Int,     favoriteCount :: {-# UNPACK #-} Int,-    tags :: [(G.TagCategory, [Text])],+    tags :: [(TagCategory, [Text])],     uploadTime :: {-# UNPACK #-} UTCTime,     newer :: Maybe Gallery,     parent :: Maybe Gallery,@@ -45,14 +137,14 @@     archiverLink :: {-# UNPACK #-} Text,     torrentLink :: {-# UNPACK #-} Text   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  data Visibility   = Visible   | Replaced   | Expunged   | Unknown {-# UNPACK #-} Text-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  readVisibility :: Text -> Visibility readVisibility "Yes" = Visible@@ -66,33 +158,111 @@   title <- annotate "title" $ d ^?: G.enTitle   previewLink <- annotate "preview link" $ d ^?: G.previewStr >>= parsePreviewLink   let jaTitle = d ^?: G.jaTitle-  category <- annotate "category" $ d ^?: G.category+  category <- annotate "category" $ d ^?: G.category >>= readCat   uploader <- annotate "uploader" $ d ^?: G.uploader-  (coerce -> rating) <- annotate "average rating" $ d ^?: G.averageRating+  rating <- annotate "average rating" $ d ^?: G.averageRating >>= parseAverageRating   ratingCount <- annotate "rating count" $ d ^?: G.ratingCount-  (coerce -> archiverLink) <- annotate "archiver link" $ d ^?: G.popupLink-  (coerce -> torrentLink) <- annotate "torrent link" $ case d ^..: G.popupLink of (_ : tl : _) -> Just tl; _ -> Nothing-  let newer = d ^?: G.newer+  archiverLink <- annotate "archiver link" $ d ^?: G.popupLink >>= parsePopUpLink+  torrentLink <- annotate "torrent link" $ case d ^..: G.popupLink of (_ : tl : _) -> Just tl; _ -> Nothing+  let newer = d ^?: G.newer >>= parseGalleryLink   case d ^..: G.metaValues of     (time : parn : vis : lang : _ : len : fav : _) -> do-      uploadTime <- annotate "upload time" $ time ^? lower . _Content >>= parseUploadTime-      let parent = parn ^? lower . _Element . attr "href" . _GalleryLink-      (readVisibility -> visibility) <- annotate "visibility" $ vis ^? lower . _Content-      (strip -> language) <- annotate "language" $ lang ^? lower . _Content-      (coerce -> length) <- annotate "length" $ len ^? lower . _Content >>= parseGalleryLength-      let cats = d ^..: G.tagCategory+      uploadTime <- annotate "upload time" $ time ^? pre lower % _Content >>= parseUploadTime+      let parent = parn ^? pre lower % _Element % attr "href" >>= parseGalleryLink+      (readVisibility -> visibility) <- annotate "visibility" $ vis ^? pre lower % _Content+      (strip -> language) <- annotate "language" $ lang ^? pre lower % _Content+      length <- annotate "length" $ len ^? pre lower % _Content >>= parseGalleryLength+      let cats = mapMaybe readTagCat (d ^..: G.tagCategory)       let tags' = map (^.. G.tags) $ d ^..: G.tagsByCategory-      unless (P.length cats == P.length tags') $ Left ""+      unless (P.length cats == P.length tags') $ Left "length of categories and tags does not match"       let tags = zip cats tags'-      (coerce -> favoriteCount) <- annotate "favorite count" $ fav ^? lower . _Content >>= parseFavoriteCount+      favoriteCount <- annotate "favorite count" $ fav ^? pre lower % _Content >>= parseFavoriteCount       pure GalleryInfo {..}     _ -> Left "extracting metadata"  -- | Fetch a gallery's 'GalleryInfo'-fetchGalleryInfo :: MonadHttpState m => Gallery -> m GalleryInfo+fetchGalleryInfo ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  Gallery ->+  m GalleryInfo fetchGalleryInfo g = do   let url = toGalleryLink g   d <- htmlRequest' url   case parseGallery d of-    Left err -> throwM $ XMLParseFailure err url+    Left err -> throw $ XMLParseFailure err url     Right info -> pure info+{-# INLINEABLE fetchGalleryInfo #-}++--------------------------------------------------+--++type Parser = Parsec Void Text++parsePopUpLink :: Text -> Maybe Text+parsePopUpLink = parseMaybe archiverLink+  where+    archiverLink :: Parser Text+    archiverLink = do+      _ <- chunk "return popUp('"+      url <- takeWhile1P Nothing (/= '\'')+      _ <- takeRest+      pure url++parseAverageRating :: Text -> Maybe Double+parseAverageRating = parseMaybe averageRating+  where+    averageRating :: Parser Double+    averageRating =+      ( do+          _ <- chunk "Average: "+          float+      )+        <|> (chunk "Not Yet Rated" >> pure 0)++parseGalleryLength :: Text -> Maybe Int+parseGalleryLength = parseMaybe galleryLength+  where+    galleryLength :: Parser Int+    galleryLength = do+      d <- decimal+      _ <- chunk " pages"+      pure d++parseFavoriteCount :: Text -> Maybe Int+parseFavoriteCount = parseMaybe favoriteCount+  where+    once = do+      _ <- chunk "Once"+      pure 1+    never = do+      _ <- chunk "Never"+      pure 0+    favoriteCount :: Parser Int+    favoriteCount =+      ( do+          d <- decimal+          _ <- chunk " times"+          pure d+      )+        <|> once+        <|> never++parsePreviewLink :: Text -> Maybe Text+parsePreviewLink = parseMaybe previewLink+  where+    previewLink :: Parser Text+    previewLink = do+      _ <- many $ do+        notFollowedBy urlOpening+        anySingle+      _ <- urlOpening+      url <- takeWhile1P Nothing (/= ')')+      _ <- takeRest+      pure url+    urlOpening :: Parser Text+    urlOpening = chunk "url("++makeFieldLabelsWith noPrefixFieldLabels ''GalleryInfo+makePrismLabels ''TagCategory+makePrismLabels ''GalleryCategory+makePrismLabels ''Visibility

@@ -1,42 +1,47 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} +-- | MPV (multi-page viewer) API. module Web.Exhentai.API.MPV   ( DispatchRequest (..),-    DispatchResult (..),-    Vars (..),     Server (..),     Dim (..),-    fetchMpv,-    toRequests,-    imageDispatch,+    buildRequest,     fetchImage,-    fetchImage',   ) where  import Conduit import Control.Applicative-import Control.Lens ((^.))-import Control.Monad.Catch+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh+import Control.Monad import Control.Monad.Trans.Cont import Data.Aeson import Data.ByteString (ByteString)-import Data.Text (Text, unpack)-import GHC.Generics-import Network.HTTP.Client.Conduit+import Data.Text (Text, pack, unpack)+import Language.JavaScript.Extraction+import Language.JavaScript.Parser+import Network.HTTP.Client hiding (Cookie)+import Optics.Core+import Optics.TH import Text.XML+import Text.XML.Optics+import Web.Exhentai.API.Gallery import Web.Exhentai.Errors-import Web.Exhentai.Parsing.MPV-import Web.Exhentai.Types-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils+import Prelude hiding ((!!))  data Server-  = HAtH Int-  | Other Text-  deriving (Show, Eq, Generic)+  = HAtH {-# UNPACK #-} Int+  | Other {-# UNPACK #-} Text+  deriving (Show, Eq)  instance FromJSON Server where   parseJSON v =@@ -57,21 +62,21 @@  data DispatchResult = DispatchResult   { -- | A piece of text describing the dimensions and the size of this image-    dimension :: Text,+    dimension :: {-# UNPACK #-} Text,     -- | The path part of the url pointing to the original image-    origImgPath :: Text,+    origImgPath :: {-# UNPACK #-} Text,     -- | The path part of the url that searches for the gallery containing this image-    searchPath :: Text,+    searchPath :: {-# UNPACK #-} Text,     -- | The path part of the non-mpv page that displays this image-    galleryPath :: Text,-    width :: Dim,-    height :: Dim,+    galleryPath :: {-# UNPACK #-} Text,+    width :: {-# UNPACK #-} Dim,+    height :: {-# UNPACK #-} Dim,     -- | The full url to this image-    imgLink :: Text,+    imgLink :: {-# UNPACK #-} Text,     -- | The server that serves this image     server :: Server   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  instance FromJSON DispatchResult where   parseJSON = withObject "imagedispatch result" $ \o ->@@ -86,13 +91,13 @@       <*> o .: "s"  data DispatchRequest = DispatchRequest-  { galleryId :: Int,-    page :: Int,-    imgKey :: Text,-    mpvKey :: Text,+  { galleryId :: {-# UNPACK #-} Int,+    page :: {-# UNPACK #-} Int,+    imgKey :: {-# UNPACK #-} Text,+    mpvKey :: {-# UNPACK #-} Text,     exclude :: Maybe Server   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  instance ToJSON DispatchRequest where   toJSON DispatchRequest {..} = object l@@ -120,34 +125,64 @@           mpvKey = mpvkey         } +toMpvLink :: Gallery -> Text+toMpvLink Gallery {..} = "https://exhentai.org/mpv/" <> pack (show galleryId) <> "/" <> token <> "/"+ -- | Fetch the 'Vars' from a Gallery's mpv page-fetchMpv :: (MonadHttpState m, MonadIO m) => Gallery -> m Vars+fetchMpv ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  Gallery ->+  m Vars fetchMpv g = htmlRequest' (toMpvLink g) >>= parseMpv+{-# INLINEABLE fetchMpv #-} -parseMpv :: (MonadIO m, MonadThrow m) => Document -> m Vars+parseMpv :: Effs '[Throw ExhentaiError] m => Document -> m Vars parseMpv doc = do-  let script = doc ^. allScripts-  res <- liftIO $ extractEnv script-  case res of-    Error e -> throwM $ ExtractionFailure e-    Success vars -> pure vars+  let script = foldOf allScripts doc+      mast = parse (unpack script) ""+  case mast of+    Left _ -> error "impossible, javascript parse failed"+    Right ast ->+      case as ast of+        Nothing -> throw ExtractionFailure+        Just vars -> pure vars+{-# INLINEABLE parseMpv #-} +-- | Build dispatch requests for a gallery+buildRequest ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  Gallery ->+  m [DispatchRequest]+buildRequest g = toRequests <$> fetchMpv g+{-# INLINEABLE buildRequest #-}+ -- | Calls the API to dispatch a image request to a H@H server-imageDispatch :: MonadHttpState m => DispatchRequest -> m DispatchResult+imageDispatch ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  DispatchRequest ->+  m DispatchResult imageDispatch dreq = do   initReq <- formRequest "https://exhentai.org/api.php"   let req = initReq {method = "POST", requestBody = RequestBodyLBS $ encode dreq}   r <- jsonRequest req   case r of-    Left e -> throwM $ JSONParseFailure e+    Left e -> throw $ JSONParseFailure e     Right res -> pure res+{-# INLINEABLE imageDispatch #-}  -- | Fetch an image with a 'DispatchRequest'-fetchImage :: (MonadHttpState m, MonadIO n) => DispatchRequest -> ContT r m (Response (ConduitT i ByteString n ()))+fetchImage ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  DispatchRequest ->+  ContT r m (Response (ConduitT i ByteString IO ())) fetchImage dreq = ContT $ \k -> bracket (fetchImage' dreq) respClose k+{-# INLINEABLE fetchImage #-}  -- | Like 'fetchImage', but the user is responsible of closing the response-fetchImage' :: (MonadHttpState m, MonadIO n) => DispatchRequest -> m (Response (ConduitT i ByteString n ()))+fetchImage' ::+  Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket, Throw ExhentaiError] m =>+  DispatchRequest ->+  m (Response (ConduitT i ByteString IO ())) fetchImage' dreq = do   res <- imageDispatch dreq   req <- formRequest $ unpack $ imgLink res@@ -157,3 +192,12 @@     openWithJar req' `catch` \(_ :: HttpException) -> do       req'' <- formRequest $ unpack $ "https://exhentai.org/" <> origImgPath res       openWithJar req''+{-# INLINEABLE fetchImage' #-}++allScripts :: Traversal' Document Text+allScripts = body .// (scripts % lower %> _Content)++makeFieldLabelsWith noPrefixFieldLabels ''DispatchResult+makeFieldLabelsWith noPrefixFieldLabels ''DispatchRequest+makePrismLabels ''Dim+makePrismLabels ''Server

@@ -1,4 +1,6 @@ {-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}  module Web.Exhentai.API.Search   ( SearchQuery (..),@@ -6,36 +8,40 @@     search,     searchRecur,     searchRecurResumable,-    searchRecurResumable',     fetchSearchPage,-    fetchSearchPage',   ) where  import Conduit-import Control.Lens ((...))-import Control.Lens.Fold+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh import Control.Monad-import Data.Set (Set, (\\))+import Data.Maybe+import Data.Set (Set, toList, (\\)) import Data.String import Data.Text (Text, unpack) import Data.Text.Encoding (encodeUtf8)-import GHC.Generics-import Network.HTTP.Client.Conduit-import Text.XML+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.Types-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils import Prelude hiding (last) +toBitField :: Set GalleryCategory -> Int+toBitField = sum . map ((2 ^) . fromEnum) . toList+ data SearchQuery = SearchQuery-  { categories :: Maybe (Set GalleryCat),+  { categories :: Maybe (Set GalleryCategory),     searchString :: {-# UNPACK #-} Text   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq) -queryArgCat :: Set GalleryCat -> Int+queryArgCat :: Set GalleryCategory -> Int queryArgCat s = toBitField $ allGalleryCats \\ s  data SearchResult = SearchResult@@ -43,33 +49,44 @@     prevPage :: Maybe Text,     nextPage :: Maybe Text   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  parseSearchPage :: Document -> SearchResult parseSearchPage d =-  let galleries = d ^..: galleryPreviewElement . galleryLink-      fld :: Fold Document Element-      fld = body ... pagesElem+  let galleries = mapMaybe parseGalleryLink $ d ^..: galleryPreviewElement % galleryLink+      fld :: Traversal' Document Element+      fld = body .// pagesElem       prevPage = do-        first <- firstOf fld d-        first ^? linkOf+        first <- headOf fld d+        first ^? pre linkOf       nextPage = do         last <- lastOf fld d-        last ^? linkOf+        last ^? pre linkOf    in SearchResult {..}  -- | Fetch a search page using a 'Request'-fetchSearchPage' :: MonadHttpState m => Request -> m SearchResult+fetchSearchPage' ::+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>+  Request ->+  m SearchResult fetchSearchPage' req = do   d <- htmlRequest req   pure $ parseSearchPage d+{-# INLINEABLE fetchSearchPage' #-}  -- | Fetch a search page using its url-fetchSearchPage :: MonadHttpState m => Text -> m SearchResult+fetchSearchPage ::+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>+  Text ->+  m SearchResult fetchSearchPage = fetchSearchPage' <=< formRequest . unpack+{-# INLINEABLE fetchSearchPage #-}  -- | Search a search query-search :: MonadHttpState m => SearchQuery -> m SearchResult+search ::+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>+  SearchQuery ->+  m SearchResult search SearchQuery {..} = do   let catQ = maybe [] (\c -> [("f_cats", Just $ fromString $ show $ queryArgCat c)]) categories   initReq <- formRequest "https://exhentai.org"@@ -81,18 +98,23 @@           )           initReq   fetchSearchPage' req+{-# INLINEABLE search #-}  -- | Iterate through all the Galleries asosciated with a search query, putting them into a stream-searchRecur :: MonadHttpState m => SearchQuery -> ConduitT i Gallery m ()+searchRecur ::+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>+  SearchQuery ->+  ConduitT i Gallery m () searchRecur q = do   SearchResult {..} <- lift $ search q   yieldMany galleries   case nextPage of     Nothing -> pure ()     Just url -> searchRecur' url+{-# INLINEABLE searchRecur #-}  searchRecur' ::-  MonadHttpState m =>+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>   -- | url   Text ->   ConduitT i Gallery m ()@@ -102,18 +124,23 @@   case nextPage of     Nothing -> pure ()     Just url' -> searchRecur' url'+{-# INLINEABLE searchRecur' #-}  -- | A resumable version of 'searchRecur' that reports it's progress.-searchRecurResumable :: MonadHttpState m => SearchQuery -> ConduitT i (Either Text Gallery) m ()+searchRecurResumable ::+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>+  SearchQuery ->+  ConduitT i (Either Text Gallery) m () searchRecurResumable q = do   SearchResult {..} <- lift $ search q   yieldMany $ map Right galleries   case nextPage of     Nothing -> pure ()     Just url -> searchRecurResumable' url+{-# INLINEABLE searchRecurResumable #-}  searchRecurResumable' ::-  MonadHttpState m =>+  Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m =>   -- | url   Text ->   ConduitT i (Either Text Gallery) m ()@@ -124,3 +151,7 @@   case nextPage of     Nothing -> pure ()     Just url' -> searchRecurResumable' url'+{-# INLINEABLE searchRecurResumable' #-}++makeFieldLabelsWith noPrefixFieldLabels ''SearchQuery+makeFieldLabelsWith noPrefixFieldLabels ''SearchResult

@@ -4,19 +4,27 @@   ) where +import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh+import Data.Maybe+import Network.HTTP.Client hiding (Cookie)+import Optics.Core+import Web.Exhentai.API.Gallery import Web.Exhentai.Parsing.Search-import Web.Exhentai.Types-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils  -- | Fetch the list of watched galleries-fetchWatched :: MonadHttpState m => m [Gallery]+fetchWatched :: Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket] m => m [Gallery] fetchWatched = do   d <- htmlRequest' "https://exhentai.org/watched"-  pure $ d ^..: galleryPreviewElement . galleryLink+  pure $ mapMaybe parseGalleryLink $ d ^..: galleryPreviewElement % galleryLink+{-# INLINEABLE fetchWatched #-}  -- | Fetch the list of popular galleries-fetchPopular :: MonadHttpState m => m [Gallery]+fetchPopular :: Effs '[Http, Error HttpException, Cookie, ConduitIO, Bracket] m => m [Gallery] fetchPopular = do   d <- htmlRequest' "https://exhentai.org/popular"-  pure $ d ^..: galleryPreviewElement . galleryLink+  pure $ mapMaybe parseGalleryLink $ d ^..: galleryPreviewElement % galleryLink+{-# INLINEABLE fetchPopular #-}

@@ -6,7 +6,6 @@  import Control.Exception import Data.Text (Text)-import GHC.Generics  data ExhentaiError   = JSONParseFailure String@@ -14,6 +13,6 @@       { reason :: Text,         url :: Text       }-  | ExtractionFailure String-  deriving (Show, Eq, Generic)+  | ExtractionFailure+  deriving (Show, Eq)   deriving (Exception)

@@ -1,122 +1,109 @@ {-# LANGUAGE RankNTypes #-} +-- | Internal module module Web.Exhentai.Parsing.Gallery where -import Control.Lens-import Data.Text (Text, pack)-import GHC.Generics+import Data.Text (Text)+import Optics.Core import Text.XML hiding (readFile)-import Text.XML.Lens-import Web.Exhentai.Types-  ( AverageRating,-    Gallery,-    GalleryCat,-    PopUpLink,-    _AverageRating,-    _GalleryCat,-    _GalleryLink,-    _PopUpLink,-  )+import Text.XML.Optics import Web.Exhentai.Utils import Prelude hiding (div, id, readFile) -data TagCategory-  = Language-  | Parody-  | Character-  | Group-  | Artist-  | Male-  | Female-  | Misc-  | Reclass-  deriving (Show, Eq, Enum, Generic)--readTagCat :: Text -> Maybe TagCategory-readTagCat "language:" = Just Language-readTagCat "parody:" = Just Parody-readTagCat "character:" = Just Character-readTagCat "group:" = Just Group-readTagCat "artist:" = Just Artist-readTagCat "male:" = Just Male-readTagCat "female:" = Just Female-readTagCat "misc:" = Just Misc-readTagCat "reclass:" = Just Reclass-readTagCat _ = Nothing--_TagCategory :: Prism' Text TagCategory-_TagCategory = prism' (pack . show) readTagCat--meta :: Traversal' Element Element-meta = div . cl "gm"+meta :: AffineTraversal' Element Element+meta = div % cl "gm"+{-# INLINE meta #-}  title :: Traversal' Element Element-title = meta ... div . id "gd2"+title = meta .// (div % id "gd2")+{-# INLINE title #-}  enTitle :: Traversal' Element Text-enTitle = title ... h1 . id "gn" . lower . _Content+enTitle = title .// (h1 % id "gn" <% lower % _Content)+{-# INLINE enTitle #-}  jaTitle :: Traversal' Element Text-jaTitle = title ... h1 . id "gj" . lower . _Content+jaTitle = title .// (h1 % id "gj" <% lower % _Content)+{-# INLINE jaTitle #-}  mainMeta :: Traversal' Element Element-mainMeta = meta ... div . id "gmid"+mainMeta = meta .// (div % id "gmid")+{-# INLINE mainMeta #-}  mainMetaL :: Traversal' Element Element-mainMetaL = mainMeta ... div . id "gd3"+mainMetaL = mainMeta .// (div % id "gd3")+{-# INLINE mainMetaL #-}  mainMetaM :: Traversal' Element Element-mainMetaM = mainMeta ... div . id "gd4"+mainMetaM = mainMeta .// (div % id "gd4")+{-# INLINE mainMetaM #-}  mainMetaR :: Traversal' Element Element-mainMetaR = mainMeta ... div . id "gd5"+mainMetaR = mainMeta .// (div % id "gd5")+{-# INLINE mainMetaR #-}  previewStr :: Traversal' Element Text-previewStr = meta ... id "gleft" ... id "gd1" ... attr "style"+previewStr = meta .// id "gleft" .// id "gd1" .// attr "style"+{-# INLINE previewStr #-} -category :: Traversal' Element GalleryCat-category = mainMetaL ... div . id "gdc" ... div . lower . _Content . _GalleryCat+category :: Traversal' Element Text+category = mainMetaL .// (div % id "gdc") .// (div <% lower % _Content)+{-# INLINE category #-}  uploader :: Traversal' Element Text-uploader = mainMetaL ... div . id "gdn" ... a . lower . _Content+uploader = mainMetaL .// (div % id "gdn") .// (a % lower %> _Content)+{-# INLINE uploader #-}  metaPath :: Traversal' Element Element-metaPath = mainMetaL ... div . id "gdd" ... table ... tr+metaPath = mainMetaL .// (div % id "gdd") .// table .// tr+{-# INLINE metaPath #-}  metaKeys :: Traversal' Element Text-metaKeys = metaPath ... cl "gdt1" . lower . _Content+metaKeys = metaPath .// (cl "gdt1" <% lower % _Content)+{-# INLINE metaKeys #-}  metaValues :: Traversal' Element Element-metaValues = metaPath ... cl "gdt2"+metaValues = metaPath .// cl "gdt2"+{-# INLINE metaValues #-} -parent :: Traversal' Element Gallery-parent = lower . _Element . attr "href" . _GalleryLink+parent :: Traversal' Element Text+parent = lower %> _Element % attr "href"+{-# INLINE parent #-}  ratingCount :: Traversal' Element Int ratingCount =-  mainMetaL ... id "gdr" ... table ... tr ... id "grt3" ... lower . _Content . viaShowRead+  mainMetaL .// id "gdr" .// table .// tr .// id "grt3" .// (lower %> _Content % viaShowRead)+{-# INLINE ratingCount #-} -averageRating :: Traversal' Element AverageRating+averageRating :: Traversal' Element Text averageRating =-  mainMetaL ... id "gdr" ... table ... tr ... id "rating_label" . lower . _Content . _AverageRating+  mainMetaL .// id "gdr" .// table .// tr .// (id "rating_label" % lower %> _Content)+{-# INLINE averageRating #-}  tagList :: Traversal' Element Element-tagList = mainMetaM ... div . id "taglist" ... table ... tr+tagList = mainMetaM .// (div % id "taglist") .// table .// tr+{-# INLINE tagList #-} -tagCategory :: Traversal' Element TagCategory-tagCategory = tagList ... td . cl "tc" . lower . _Content . _TagCategory+tagCategory :: Traversal' Element Text+tagCategory = tagList .// (td % cl "tc" % lower %> _Content)+{-# INLINE tagCategory #-}  tagsByCategory :: Traversal' Element Element-tagsByCategory = tagList ... td . withoutAttribute "class"+tagsByCategory = tagList .// (td % withoutAttribute "class")+{-# INLINE tagsByCategory #-}  tags :: Traversal' Element Text-tags = td ... div ... a . lower . _Content+tags = td .// div .// (a % lower %> _Content)+{-# INLINE tags #-} -popupLink :: Traversal' Element PopUpLink-popupLink = mainMetaR ... named "p" ... attr "onclick" . _PopUpLink+popupLink :: Traversal' Element Text+popupLink = mainMetaR .// named "p" .// attr "onclick"+{-# INLINE popupLink #-}  imagePages :: Traversal' Element Text-imagePages = div . id "gdt" ... cl "gdtl" ... a . attr "href"+imagePages = (div % id "gdt") .// cl "gdtl" .// (a % attr "href")+{-# INLINE imagePages #-} -newer :: Traversal' Element Gallery-newer = div . id "gnd" ... a . attr "href" . _GalleryLink+newer :: Traversal' Element Text+newer = (div % id "gnd") .// (a % attr "href")+{-# INLINE newer #-}

@@ -1,13 +1,16 @@+-- | Internal module module Web.Exhentai.Parsing.Image where -import Control.Lens import Data.Text (Text)-import Text.XML.Lens+import Optics.Core+import Text.XML.Optics import Web.Exhentai.Utils import Prelude hiding (id)  imageSrc :: Traversal' Element Text-imageSrc = id "i1" ... id "i3" ... a ... img . attr "src"+imageSrc = id "i1" .// id "i3" .// a .// (img % attr "src")+{-# INLINE imageSrc #-} -nextPage :: Traversal' Element Text-nextPage = id "i1" ... id "i3" ... a . attr "href"+nextImage :: Traversal' Element Text+nextImage = id "i1" .// id "i3" .// (a % attr "href")+{-# INLINE nextImage #-}

@@ -1,55 +0,0 @@-{-# LANGUAGE StrictData #-}--module Web.Exhentai.Parsing.MPV where--import Control.Lens-import Data.Aeson-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)-import GHC.Generics-import Quickjs-import Text.XML.Lens-import Web.Exhentai.Utils--allScripts :: Traversal' Document Text-allScripts = body ... scripts . lower . _Content--data MpvImage = MpvImage-  { name :: {-# UNPACK #-} Text,-    key :: {-# UNPACK #-} Text,-    thumbnail :: {-# UNPACK #-} Text-  }-  deriving (Show, Eq, Generic)--instance FromJSON MpvImage where-  parseJSON = withObject "mpv image" $ \o ->-    MpvImage-      <$> o .: "n"-      <*> o .: "k"-      <*> o .: "t"---- | All the variables defined in the scripts that came with the MPV-data Vars = Vars-  { gid :: {-# UNPACK #-} Int,-    mpvkey :: {-# UNPACK #-} Text,-    apiUrl :: {-# UNPACK #-} Text,-    pageCount :: {-# UNPACK #-} Int,-    imageList :: [MpvImage]-  }-  deriving (Show, Eq, Generic)--extractEnv :: Text -> IO (Result Vars)-extractEnv script = quickjs $ do-  eval_ $ encodeUtf8 script-  gid' <- eval "gid"-  mpvkey' <- eval "mpvkey"-  imageList' <- eval "imagelist"-  apiUrl' <- eval "api_url"-  pageCount' <- eval "pagecount"-  pure $ do-    gid <- fromJSON gid'-    mpvkey <- fromJSON mpvkey'-    imageList <- fromJSON imageList'-    apiUrl <- fromJSON apiUrl'-    pageCount <- fromJSON pageCount'-    pure Vars {..}

@@ -1,32 +1,36 @@+-- | Internal modules module Web.Exhentai.Parsing.Search where -import Control.Lens import Data.Text (Text)-import Text.XML.Lens-import Web.Exhentai.Types+import Optics.Core+import Text.XML.Optics import Web.Exhentai.Utils import Prelude hiding (div)  pages :: Traversal' Element Int-pages = pagesElem ... a . lower . _Content . viaShowRead+pages = pagesElem .// (a % lower %> _Content % viaShowRead)+{-# INLINE pages #-}  pagesElem :: Traversal' Element Element-pagesElem = cl "ido" ... div ... cl "ptt" ... tr ... td+pagesElem = cl "ido" .// div .// cl "ptt" .// tr .// td+{-# INLINE pagesElem #-}  linkOf :: Traversal' Element Text-linkOf = lower . _Element . attr "href"+linkOf = lower %> _Element % attr "href"+{-# INLINE linkOf #-}  galleryPreviewElement :: Traversal' Element Element-galleryPreviewElement = cl "ido" ... div ... cl "itg glte" ... tr+galleryPreviewElement = cl "ido" .// div .// cl "itg glte" .// tr+{-# INLINE galleryPreviewElement #-}  previewImage :: Traversal' Element Text-previewImage = tr ... cl "gl1e" ... div ... a ... img . attr "src"+previewImage = tr .// cl "gl1e" .// div .// a .// (img % attr "src")+{-# INLINE previewImage #-}  title :: Traversal' Element Text-title = tr ... cl "gl1e" ... div ... a ... img . attr "title"--galleryLink :: Traversal' Element Gallery-galleryLink = tr ... cl "gl1e" ... div ... a . attr "href" . _GalleryLink+title = tr .// cl "gl1e" .// div .// a .// (img % attr "title")+{-# INLINE title #-} -galleryLength :: Traversal' Element GalleryLength-galleryLength = tr ... cl "gl2e" ... div ... cl "gl3e" ... lower . _Content . _GalleryLength+galleryLink :: Traversal' Element Text+galleryLink = tr .// cl "gl1e" .// div .// (a % attr "href")+{-# INLINE galleryLink #-}

@@ -1,187 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Web.Exhentai.Types where--import Control.Applicative ((<|>))-import Control.Lens-import Data.Set (Set, fromList, toList)-import Data.Text (Text, pack)-import Data.Void-import GHC.Generics-import Text.Megaparsec-  ( MonadParsec (notFollowedBy, takeWhile1P),-    Parsec,-    anySingle,-    chunk,-    many,-    optional,-    parseMaybe,-    single,-    takeRest,-  )-import Text.Megaparsec.Char.Lexer--type Parser = Parsec Void Text--data GalleryCat-  = Misc-  | Doujinshi-  | Manga-  | ArtistCG-  | GameCG-  | ImageSet-  | Cosplay-  | AsianPorn-  | NonH-  | Western-  | Private-  deriving (Show, Eq, Ord, Enum, Bounded)--allGalleryCats :: Set GalleryCat-allGalleryCats = fromList [Misc .. Private]--toBitField :: Set GalleryCat -> Int-toBitField = sum . map ((2 ^) . fromEnum) . toList--showCat :: GalleryCat -> Text-showCat Doujinshi = "Doujinshi"-showCat Manga = "Manga"-showCat ArtistCG = "Artist CG"-showCat GameCG = "Game CG"-showCat NonH = "Non-H"-showCat ImageSet = "Image Set"-showCat Western = "Western"-showCat Cosplay = "Cosplay"-showCat Misc = "Misc"-showCat Private = "Private"-showCat AsianPorn = "Asian Porn"--readCat :: Text -> Maybe GalleryCat-readCat "Doujinshi" = Just Doujinshi-readCat "Manga" = Just Manga-readCat "Artist CG" = Just ArtistCG-readCat "Game CG" = Just GameCG-readCat "Non-H" = Just NonH-readCat "Image Set" = Just ImageSet-readCat "Western" = Just Western-readCat "Cosplay" = Just Cosplay-readCat "Misc" = Just Misc-readCat "Private" = Just Private-readCat "Asian Porn" = Just AsianPorn-readCat _ = Nothing--_GalleryCat :: Prism' Text GalleryCat-_GalleryCat = prism' showCat readCat--newtype PopUpLink = PopUpLink {unLink :: Text}-  deriving newtype (Show, Eq)--_PopUpLink :: Prism' Text PopUpLink-_PopUpLink = prism' unLink parsePopUpLink--parsePopUpLink :: Text -> Maybe PopUpLink-parsePopUpLink = parseMaybe archiverLink-  where-    archiverLink :: Parser PopUpLink-    archiverLink = do-      _ <- chunk "return popUp('"-      url <- takeWhile1P Nothing (/= '\'')-      _ <- takeRest-      pure $ PopUpLink url--newtype AverageRating = AverageRating {unRating :: Float}-  deriving newtype (Show, Eq)--_AverageRating :: Prism' Text AverageRating-_AverageRating = prism' (pack . show . unRating) parseAverageRating--parseAverageRating :: Text -> Maybe AverageRating-parseAverageRating = parseMaybe averageRating-  where-    averageRating :: Parser AverageRating-    averageRating =-      ( do-          _ <- chunk "Average: "-          AverageRating <$> float-      )-        <|> (chunk "Not Yet Rated" >> pure (AverageRating 0))--newtype GalleryLength = GalleryLength {unGalleryLength :: Int}-  deriving newtype (Show, Eq)--_GalleryLength :: Prism' Text GalleryLength-_GalleryLength = prism' (pack . show . unGalleryLength) parseGalleryLength--parseGalleryLength :: Text -> Maybe GalleryLength-parseGalleryLength = parseMaybe galleryLength-  where-    galleryLength :: Parser GalleryLength-    galleryLength = do-      d <- decimal-      _ <- chunk " pages"-      pure $ GalleryLength d--newtype FavoriteCount = FavoriteCount {unFavoriteCount :: Int}-  deriving newtype (Show, Eq)--parseFavoriteCount :: Text -> Maybe FavoriteCount-parseFavoriteCount = parseMaybe favoriteCount-  where-    once = do-      _ <- chunk "Once"-      pure $ FavoriteCount 1-    never = do-      _ <- chunk "Never"-      pure $ FavoriteCount 0-    favoriteCount :: Parser FavoriteCount-    favoriteCount =-      ( do-          d <- decimal-          _ <- chunk " times"-          pure $ FavoriteCount d-      )-        <|> once-        <|> never--data Gallery = Gallery-  { galleryId :: {-# UNPACK #-} !Int,-    token :: {-# UNPACK #-} !Text-  }-  deriving (Show, Eq, Generic)--_GalleryLink :: Prism' Text Gallery-_GalleryLink = prism' toGalleryLink parseGalleryLink--toGalleryLink :: Gallery -> Text-toGalleryLink Gallery {..} = "https://exhentai.org/g/" <> pack (show galleryId) <> "/" <> token <> "/"--toMpvLink :: Gallery -> Text-toMpvLink Gallery {..} = "https://exhentai.org/mpv/" <> pack (show galleryId) <> "/" <> token <> "/"--parseGalleryLink :: Text -> Maybe Gallery-parseGalleryLink = parseMaybe galleryLink-  where-    galleryLink :: Parser Gallery-    galleryLink = do-      _ <- chunk "https://exhentai.org/g/"-      galleryId <- decimal-      _ <- single '/'-      token <- takeWhile1P Nothing (/= '/')-      _ <- optional $ single '/'-      pure Gallery {..}--parsePreviewLink :: Text -> Maybe Text-parsePreviewLink = parseMaybe previewLink-  where-    previewLink :: Parser Text-    previewLink = do-      _ <- many $ do-        notFollowedBy urlOpening-        anySingle-      _ <- urlOpening-      url <- takeWhile1P Nothing (/= ')')-      _ <- takeRest-      pure url-    urlOpening :: Parser Text-    urlOpening = chunk "url("

@@ -1,180 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE UndecidableInstances #-}--module Web.Exhentai.Types.CookieT where--import Conduit-import Control.Concurrent-import Control.Monad.Base-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Time-import Control.Monad.Trans.Control-import Control.Retry-import Data.ByteString (ByteString)-import Data.Function ((&))-import GHC.Generics-import Network.HTTP.Client.Conduit-import Network.HTTP.Client.MultipartFormData-import Network.HTTP.Client.TLS--newtype Policy = Policy RetryPolicy--class (Monad m, MonadCatch m, MonadThrow m) => MonadHttp m where-  getRetryPolicy :: m Policy-  formRequest :: String -> m Request-  attachFormData :: [Part] -> Request -> m Request-  respOpen :: MonadIO n => Request -> m (Response (ConduitT i ByteString n ()))-  respClose :: Response body -> m ()-  reqNoBody :: Request -> m (Response ())--class (MonadMask m, MonadTime m, MonadHttp m, MonadIO m) => MonadHttpState m where-  takeCookieJar :: m CookieJar-  readCookieJar :: m CookieJar-  putCookieJar :: CookieJar -> m ()--modifyingJar :: MonadHttpState m => Request -> m ()-modifyingJar req =-  bracketOnError-    takeCookieJar-    putCookieJar-    $ \jar -> do-      let req' = req {cookieJar = Just jar}-      resp <- retryWhenTimeout $ reqNoBody req'-      putCookieJar $ responseCookieJar resp-      pure ()--openWithJar :: (MonadHttpState m, MonadIO n) => Request -> m (Response (ConduitT i ByteString n ()))-openWithJar req = do-  jar <- readCookieJar-  let req' = req {cookieJar = Just jar}-  respOpen req'--withJar :: (MonadHttpState m, MonadIO n) => Request -> (ConduitT i ByteString n () -> m a) -> m a-withJar req k = do-  jar <- readCookieJar-  let req' = req {cookieJar = Just jar}-  bracket-    (respOpen req')-    respClose-    (k . responseBody)--data CookieEnv = CookieEnv-  { policy :: Policy,-    jarRef :: MVar CookieJar,-    manager :: {-# UNPACK #-} !Manager-  }-  deriving (Generic)--instance HasHttpManager CookieEnv where-  getHttpManager = manager--newtype CookieT m a = CookieT {unCookieT :: ReaderT CookieEnv m a}-  deriving newtype-    ( Functor,-      Applicative,-      Monad,-      MonadReader CookieEnv,-      MonadThrow,-      MonadCatch,-      MonadMask,-      MonadIO,-      MonadResource,-      MonadUnliftIO,-      MonadError e,-      MonadBase b,-      MonadBaseControl b,-      MonadTime-    )--runCookieT :: MonadIO m => RetryPolicy -> CookieT m a -> m a-runCookieT (Policy -> policy) m = do-  manager <- liftIO newTlsManager-  jarRef <- liftIO $ newMVar mempty-  m-    & unCookieT-    & flip runReaderT CookieEnv {..}--instance MonadTrans CookieT where-  lift = CookieT . lift--instance-  ( MonadIO m,-    MonadUnliftIO m,-    MonadCatch m,-    MonadThrow m-  ) =>-  MonadHttp (CookieT m)-  where-  getRetryPolicy = asks policy-  formRequest = parseRequest-  attachFormData = formDataBody-  respOpen = responseOpen-  respClose = responseClose-  reqNoBody = httpNoBody--instance-  {-# OVERLAPPABLE #-}-  ( MonadHttp m,-    MonadTrans f,-    Monad (f m),-    MonadCatch (f m),-    MonadThrow (f m)-  ) =>-  MonadHttp (f m)-  where-  getRetryPolicy = lift getRetryPolicy-  formRequest = lift . formRequest-  attachFormData p = lift . attachFormData p-  respOpen = lift . respOpen-  respClose = lift . respClose-  reqNoBody = lift . reqNoBody--retryWhenTimeout :: MonadHttpState m => m a -> m a-retryWhenTimeout action = do-  Policy policy <- getRetryPolicy-  recovering policy handlers (const action)-  where-    handlers =-      skipAsyncExceptions-        ++ [ const (Handler (pure . judge))-           ]-    judge (HttpExceptionRequest _ c)-      | ResponseTimeout <- c = True-      | ConnectionTimeout <- c = True-    judge _ = False--instance-  ( MonadMask m,-    MonadUnliftIO m,-    MonadTime m-  ) =>-  MonadHttpState (CookieT m)-  where-  takeCookieJar = do-    ref <- asks jarRef-    liftIO $ takeMVar ref-  putCookieJar jar = do-    ref <- asks jarRef-    liftIO $ putMVar ref jar-  readCookieJar = do-    ref <- asks jarRef-    liftIO $ readMVar ref--instance-  {-# OVERLAPPABLE #-}-  ( MonadHttpState m,-    MonadTrans f,-    MonadMask (f m),-    MonadTime (f m),-    MonadHttp (f m),-    MonadIO (f m)-  ) =>-  MonadHttpState (f m)-  where-  takeCookieJar = lift takeCookieJar-  putCookieJar = lift . putCookieJar-  readCookieJar = lift readCookieJar

@@ -1,86 +1,100 @@ {-# LANGUAGE RankNTypes #-} +-- | Internal module module Web.Exhentai.Utils where  import Conduit-import Control.Lens+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Exh+import Control.Monad.Trans.Cont import Data.Aeson import Data.ByteString (ByteString)-import Data.Maybe (isNothing) import Data.Text (Text, pack, unpack) import Data.Time-import Network.HTTP.Client.Conduit+import Network.HTTP.Client hiding (Cookie)+import Optics.Core import Text.HTML.DOM-import Text.Read+import Text.Read (readMaybe) import Text.XML hiding (sinkDoc)-import Text.XML.Lens-import Web.Exhentai.Types.CookieT--attributeSatisfies' :: Name -> (Maybe Text -> Bool) -> Traversal' Element Element-attributeSatisfies' n p = filtered (p . preview (attrs . ix n))--withoutAttribute :: Name -> Traversal' Element Element-withoutAttribute = flip attributeSatisfies' isNothing--lower :: Traversal' Element Node-lower = nodes . traverse+import Text.XML.Optics+import Prelude hiding ((!!))  body :: Traversal' Document Element-body = root . named "html" ... named "body"+body = (root % named "html") .// named "body"+{-# INLINE body #-} -div :: Traversal' Element Element+div :: AffineTraversal' Element Element div = named "div"+{-# INLINE div #-} -h1 :: Traversal' Element Element+h1 :: AffineTraversal' Element Element h1 = named "h1"+{-# INLINE h1 #-} -a :: Traversal' Element Element+a :: AffineTraversal' Element Element a = named "a"+{-# INLINE a #-} -table :: Traversal' Element Element+table :: AffineTraversal' Element Element table = named "table"+{-# INLINE table #-} -tr :: Traversal' Element Element+tr :: AffineTraversal' Element Element tr = named "tr"+{-# INLINE tr #-} -td :: Traversal' Element Element+td :: AffineTraversal' Element Element td = named "td"+{-# INLINE td #-} -img :: Traversal' Element Element+img :: AffineTraversal' Element Element img = named "img"+{-# INLINE img #-} -cl :: Text -> Traversal' Element Element+cl :: Text -> AffineTraversal' Element Element cl = attributeIs "class"+{-# INLINE cl #-} -id :: Text -> Traversal' Element Element+id :: Text -> AffineTraversal' Element Element id = attributeIs "id"+{-# INLINE id #-}  viaShowRead :: (Show a, Read a) => Prism' Text a viaShowRead = prism' (pack . show) (readMaybe . unpack)+{-# INLINE viaShowRead #-} -scripts :: Traversal' Element Element-scripts = named "script" . attributeIs "type" "text/javascript"+scripts :: AffineTraversal' Element Element+scripts = named "script" % attributeIs "type" "text/javascript"+{-# INLINE scripts #-}  infixl 8 ^?: -(^?:) :: Document -> Fold Element a -> Maybe a-doc ^?: fld = doc ^? body ... fld+(^?:) :: (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 -> Maybe a+doc ^?: fld = doc ^? pre (body .// fld)+{-# INLINE (^?:) #-}  infixl 8 ^..: -(^..:) :: Document -> Fold Element a -> [a]-doc ^..: fld = doc ^.. body ... fld+(^..:) :: (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]+doc ^..: fld = doc ^.. body .// fld+{-# INLINE (^..:) #-}  sinkAeson :: (FromJSON a, Monad m) => ConduitT ByteString o m (Either String a) sinkAeson = eitherDecode <$> sinkLazy -jsonRequest :: (FromJSON a, MonadHttpState m) => Request -> m (Either String a)-jsonRequest req = withJar req $ \source -> runConduit $ source .| sinkAeson+jsonRequest :: (FromJSON a, Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m) => Request -> m (Either String a)+jsonRequest req = evalContT $ do+  resp <- withSource req+  lift $ runConduitIO $ responseBody resp .| sinkAeson -htmlRequest :: MonadHttpState m => Request -> m Document-htmlRequest req = withJar req $ \source -> runConduit $ source .| sinkDoc+htmlRequest :: Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m => Request -> m Document+htmlRequest req = evalContT $ do+  resp <- withSource req+  lift $ runConduitIO $ responseBody resp .| sinkDoc -htmlRequest' :: MonadHttpState m => Text -> m Document+htmlRequest' :: Effs '[Http, Error HttpException, ConduitIO, Cookie, Bracket] m => Text -> m Document htmlRequest' url = do   req <- formRequest $ unpack url   htmlRequest req@@ -91,3 +105,14 @@ annotate :: ann -> Maybe a -> Either ann a annotate _ (Just a') = Right a' annotate ann Nothing = Left ann++(!!) :: [a] -> Int -> Maybe a+l !! i+  | i == 0,+    (x : _) <- l =+    Just x+  | i > 0,+    (_ : xs) <- l =+    xs !! (i - 1)+  | otherwise = Nothing+{-# INLINE (!!) #-}

@@ -1,42 +1,21 @@ module Main where -import Conduit-import Control.Monad.Trans.Cont-import Control.Retry import Data.Either import Data.Maybe-import Network.HTTP.Client+import Optics.Core import Test.Hspec import Text.HTML.DOM-import Web.Exhentai.API.Auth import Web.Exhentai.API.Gallery-import Web.Exhentai.API.MPV import qualified Web.Exhentai.Parsing.Gallery as G import Web.Exhentai.Parsing.Image import qualified Web.Exhentai.Parsing.Search as S-import Web.Exhentai.Types-import Web.Exhentai.Types.CookieT import Web.Exhentai.Utils import Prelude hiding (readFile)  main :: IO () main = do   sanityCheck-  runCookieT retryPolicyDefault $ do-    auth $ Credential "VictorYu" "Victor142857"-    vars <- fetchMpv $ Gallery 1815207 "5f4ceed6d7"-    withSinkFile "1.png" $ \sinkF -> evalContT $ do-      resp <- fetchImage $ head $ toRequests vars-      let source = responseBody resp-      runConduit $ source .| sinkF -{--    withSinkFile "2.zip" $ \sinkF -> evalContT $ do-      resp <- streamOriginal "https://exhentai.org/archiver.php?gid=1800698&token=3d413c962e&or=447251--2c3a0356a675f5eb4c5a2afe08b9f15e385647bb"-      let source = responseBody resp-      runConduit $ source .| sinkF--}- sanityCheck :: IO () sanityCheck = do   image <- readFile "test/Image.html"@@ -52,7 +31,7 @@      describe "Image.nextPage" $ do       it "should return the link to the next page" $ do-        (image ^?: nextPage) `shouldSatisfy` isJust+        (image ^?: nextImage) `shouldSatisfy` isJust      describe "Gallery.enTitle" $ do       it "should return the title of the gallery" $ do@@ -113,4 +92,4 @@      describe "Search.galleryLink" $ do       it "should return galleries" $ do-        (search ^?: S.galleryPreviewElement . S.galleryLink) `shouldSatisfy` isJust+        (search ^?: S.galleryPreviewElement % S.galleryLink) `shouldSatisfy` isJust