exh 0.1.0 → 0.2.0

raw patch · 11 files changed

+116/−55 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• exh.cabal +3/−3
• src/Web/Exhentai/API/Archiver.hs +1/−1
• src/Web/Exhentai/API/Auth.hs +2/−1
• src/Web/Exhentai/API/Gallery.hs +22/−20
• src/Web/Exhentai/API/Search.hs +38/−10
• src/Web/Exhentai/Errors.hs +6/−2
• src/Web/Exhentai/Parsing/Gallery.hs +6/−6
• src/Web/Exhentai/Types.hs +23/−8
• src/Web/Exhentai/Utils.hs +4/−0
• test/Spec.hs +6/−4

@@ -3,3 +3,8 @@ ## 0.1.0  Initial release++## 0.2.0++- Bug fixes+- Add a resumable variant of the search function

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            exh-version:         0.1.0+version:         0.2.0 synopsis:        A library for crawling exhentai description:   A library for crawling exhentai, with the support of streaming@@ -20,7 +20,7 @@  common common-attrs   build-depends:-    , aeson              ^>=1.5.4+    , aeson              >=1.4.7   && <1.6     , base               >=4.10    && <5     , bytestring         >=0.10.12 && <0.12     , conduit            ^>=1.3.4@@ -42,7 +42,7 @@     , transformers       ^>=0.5.6     , transformers-base  ^>=0.4.5     , xml-conduit        >=1.8.0   && <1.10-    , xml-lens           >=0.2     && <0.4+    , xml-lens           >=0.2     && <0.3    default-language:   Haskell2010   default-extensions:

@@ -41,7 +41,7 @@   req <- formDataBody parts initReq   d <- htmlRequest req   case d ^?: downloadLink of-    Nothing -> throwM $ XMLParseFailure url+    Nothing -> throwM $ XMLParseFailure "download link" url     Just l -> do       newReq <- formRequest $ unpack l       let req' = setQueryString [("start", Just "1")] newReq

@@ -5,6 +5,7 @@ where  import Data.ByteString (ByteString)+import GHC.Generics import Network.HTTP.Client.Conduit import Network.HTTP.Client.MultipartFormData import Web.Exhentai.Types.CookieT@@ -13,7 +14,7 @@   { username :: ByteString,     password :: ByteString   }-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)  -- | Authenticates and loads user preferences. -- This should be called before any other functions are called

@@ -30,7 +30,7 @@   { title :: {-# UNPACK #-} Text,     previewLink :: {-# UNPACK #-} Text,     category :: GalleryCat,-    jaTitle :: {-# UNPACK #-} Text,+    jaTitle :: Maybe Text,     uploader :: {-# UNPACK #-} Text,     rating :: {-# UNPACK #-} Float,     ratingCount :: {-# UNPACK #-} Int,@@ -42,7 +42,8 @@     visibility :: Visibility,     language :: {-# UNPACK #-} Text,     length :: {-# UNPACK #-} Int,-    archiverLink :: {-# UNPACK #-} Text+    archiverLink :: {-# UNPACK #-} Text,+    torrentLink :: {-# UNPACK #-} Text   }   deriving (Show, Eq, Generic) @@ -60,31 +61,32 @@ readVisibility v = Unknown v  -- | Extract all gallery informations from a document-parseGallery :: Document -> Maybe GalleryInfo+parseGallery :: Document -> Either Text GalleryInfo parseGallery d = do-  title <- d ^?: G.enTitle-  previewLink <- d ^?: G.previewStr >>= parsePreviewLink-  jaTitle <- d ^?: G.jaTitle-  category <- d ^?: G.category-  uploader <- d ^?: G.uploader-  (coerce -> rating) <- d ^?: G.averageRating-  ratingCount <- d ^?: G.ratingCount-  (coerce -> archiverLink) <- d ^?: G.archiverLink+  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+  uploader <- annotate "uploader" $ d ^?: G.uploader+  (coerce -> rating) <- annotate "average rating" $ d ^?: G.averageRating+  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   case d ^..: G.metaValues of     (time : parn : vis : lang : _ : len : fav : _) -> do-      uploadTime <- time ^? lower . _Content >>= parseUploadTime+      uploadTime <- annotate "upload time" $ time ^? lower . _Content >>= parseUploadTime       let parent = parn ^? lower . _Element . attr "href" . _GalleryLink-      (readVisibility -> visibility) <- vis ^? lower . _Content-      (strip -> language) <- lang ^? lower . _Content-      (coerce -> length) <- len ^? lower . _Content >>= parseGalleryLength+      (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       let tags' = map (^.. G.tags) $ d ^..: G.tagsByCategory-      guard $ P.length cats == P.length tags'+      unless (P.length cats == P.length tags') $ Left ""       let tags = zip cats tags'-      (coerce -> favoriteCount) <- fav ^? lower . _Content >>= parseFavoriteCount+      (coerce -> favoriteCount) <- annotate "favorite count" $ fav ^? lower . _Content >>= parseFavoriteCount       pure GalleryInfo {..}-    _ -> Nothing+    _ -> Left "extracting metadata"  -- | Fetch a gallery's 'GalleryInfo' fetchGalleryInfo :: MonadHttpState m => Gallery -> m GalleryInfo@@ -92,5 +94,5 @@   let url = toGalleryLink g   d <- htmlRequest' url   case parseGallery d of-    Nothing -> throwM $ XMLParseFailure url-    Just info -> pure info+    Left err -> throwM $ XMLParseFailure err url+    Right info -> pure info

@@ -5,6 +5,8 @@     SearchResult (..),     search,     searchRecur,+    searchRecurResumable,+    searchRecurResumable',     fetchSearchPage,     fetchSearchPage',   )@@ -80,19 +82,45 @@           initReq   fetchSearchPage' req --- | Iterate through all the Galleries asosciated with a search query, putting them in a stream-searchRecur :: forall m i. MonadHttpState m => SearchQuery -> ConduitT i Gallery m ()+-- | Iterate through all the Galleries asosciated with a search query, putting them into a stream+searchRecur :: MonadHttpState m => SearchQuery -> ConduitT i Gallery m () searchRecur q = do   SearchResult {..} <- lift $ search q   yieldMany galleries   case nextPage of     Nothing -> pure ()     Just url -> searchRecur' url-  where-    searchRecur' :: Text -> ConduitT i Gallery m ()-    searchRecur' url = do-      SearchResult {..} <- lift $ fetchSearchPage url-      yieldMany galleries-      case nextPage of-        Nothing -> pure ()-        Just url' -> searchRecur' url'++searchRecur' ::+  MonadHttpState m =>+  -- | url+  Text ->+  ConduitT i Gallery m ()+searchRecur' url = do+  SearchResult {..} <- lift $ fetchSearchPage url+  yieldMany galleries+  case nextPage of+    Nothing -> pure ()+    Just url' -> searchRecur' url'++-- | A resumable version of 'searchRecur' that reports it's progress.+searchRecurResumable :: MonadHttpState 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++searchRecurResumable' ::+  MonadHttpState m =>+  -- | url+  Text ->+  ConduitT i (Either Text Gallery) m ()+searchRecurResumable' url = do+  yield $ Left url+  SearchResult {..} <- lift $ fetchSearchPage url+  yieldMany $ map Right galleries+  case nextPage of+    Nothing -> pure ()+    Just url' -> searchRecurResumable' url'

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

@@ -4,6 +4,7 @@  import Control.Lens import Data.Text (Text, pack)+import GHC.Generics import Text.XML hiding (readFile) import Text.XML.Lens import Web.Exhentai.Types@@ -28,7 +29,8 @@   | Male   | Female   | Misc-  deriving (Show, Eq, Enum)+  | Reclass+  deriving (Show, Eq, Enum, Generic)  readTagCat :: Text -> Maybe TagCategory readTagCat "language:" = Just Language@@ -39,6 +41,7 @@ readTagCat "male:" = Just Male readTagCat "female:" = Just Female readTagCat "misc:" = Just Misc+readTagCat "reclass:" = Just Reclass readTagCat _ = Nothing  _TagCategory :: Prism' Text TagCategory@@ -109,11 +112,8 @@ tags :: Traversal' Element Text tags = td ... div ... a . lower . _Content -archiverLink :: Traversal' Element PopUpLink-archiverLink = mainMetaR ... cl "g2 gsp" ... attr "onclick" . _PopUpLink--torrentLink :: Traversal' Element PopUpLink-torrentLink = mainMetaR ... cl "g2" ... attr "onclick" . _PopUpLink+popupLink :: Traversal' Element PopUpLink+popupLink = mainMetaR ... named "p" ... attr "onclick" . _PopUpLink  imagePages :: Traversal' Element Text imagePages = div . id "gdt" ... cl "gdtl" ... a . attr "href"

@@ -3,10 +3,12 @@  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,@@ -98,9 +100,12 @@ parseAverageRating = parseMaybe averageRating   where     averageRating :: Parser AverageRating-    averageRating = do-      _ <- chunk "Average: "-      AverageRating <$> float+    averageRating =+      ( do+          _ <- chunk "Average: "+          AverageRating <$> float+      )+        <|> (chunk "Not Yet Rated" >> pure (AverageRating 0))  newtype GalleryLength = GalleryLength {unGalleryLength :: Int}   deriving newtype (Show, Eq)@@ -123,17 +128,27 @@ 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+    favoriteCount =+      ( do+          d <- decimal+          _ <- chunk " times"+          pure $ FavoriteCount d+      )+        <|> once+        <|> never  data Gallery = Gallery   { galleryId :: {-# UNPACK #-} !Int,     token :: {-# UNPACK #-} !Text   }-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)  _GalleryLink :: Prism' Text Gallery _GalleryLink = prism' toGalleryLink parseGalleryLink

@@ -87,3 +87,7 @@  parseUploadTime :: Text -> Maybe UTCTime parseUploadTime s = parseTimeM True defaultTimeLocale "%F %R" $ unpack s++annotate :: ann -> Maybe a -> Either ann a+annotate _ (Just a') = Right a'+annotate ann Nothing = Left ann

@@ -3,6 +3,7 @@ import Conduit import Control.Monad.Trans.Cont import Control.Retry+import Data.Either import Data.Maybe import Network.HTTP.Client import Test.Hspec@@ -43,7 +44,7 @@   galleryNonMpv <- readFile "test/Gallery-NonMPV.html"   galleryReplaced <- readFile "test/Gallery-Replaced.html"   search <- readFile "test/Search-Extended.html"-  archiver <- readFile "test/Archiver-Download.html"+  galleryWithAd <- readFile "test/Gallery-ADs.html"   hspec $ do     describe "Image.imageSrc" $ do       it "should return the image source link" $ do@@ -97,9 +98,10 @@      describe "Gallery.parseGallery" $ do       it "should parse gallery just fine" $ do-        parseGallery galleryMpv `shouldSatisfy` isJust-        parseGallery galleryNonMpv `shouldSatisfy` isJust-        parseGallery galleryReplaced `shouldSatisfy` isJust+        parseGallery galleryMpv `shouldSatisfy` isRight+        parseGallery galleryNonMpv `shouldSatisfy` isRight+        parseGallery galleryReplaced `shouldSatisfy` isRight+        parseGallery galleryWithAd `shouldSatisfy` isRight      describe "Search.pages" $ do       it "should return available page range" $ do