packages feed

h-booru 0.2.0.0 → 0.3.0.0

raw patch · 10 files changed

+507/−71 lines, 10 filesdep +containersdep +directorydep +filepathdep ~base

Dependencies added: containers, directory, filepath, mtl, stm, transformers

Dependency ranges changed: base

Files

h-booru.cabal view
@@ -1,5 +1,5 @@ name:                h-booru-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Haskell library for retrieving data from various booru image sites description:         Haskell library for retrieving data from various booru image sites.                      By providing a common interface for such sites and some parsers for@@ -13,40 +13,66 @@ category:            Web build-type:          Simple extra-source-files:  README.md-cabal-version:       >=1.10+cabal-version:       >=1.16+ source-repository head   type:     git   location: git@github.com:Fuuzetsu/h-booru.git  library+  ghc-options:         -O2 -threaded   hs-source-dirs:      src   default-language:    Haskell2010   exposed-modules:     HBooru.Types     HBooru.Network+    HBooru.Parsers.FieldParsers     HBooru.Parsers.Gelbooru     HBooru.Parsers.Ichijou     HBooru.Parsers.Konachan     HBooru.Parsers.Safebooru     HBooru.Parsers.Yandere-  build-depends:       base >=4.6 && <5, hxt >= 9.3.1.2, template-haskell-                       , http-conduit, utf8-string, bytestring, vinyl >= 0.4-+  build-depends:+      base >=4 && <5+    , bytestring+    , filepath+    , http-conduit+    , hxt >= 9.3.1.2+    , mtl+    , stm+    , template-haskell+    , transformers+    , utf8-string+    , vinyl >= 0.4  executable h-booru+  ghc-options:         -O2 -threaded   hs-source-dirs:      src   default-language:    Haskell2010   main-is: Main.hs   other-modules:     HBooru.Types     HBooru.Network+    HBooru.Parsers.FieldParsers     HBooru.Parsers.Gelbooru     HBooru.Parsers.Ichijou     HBooru.Parsers.Konachan     HBooru.Parsers.Safebooru     HBooru.Parsers.Yandere-  build-depends:       base >=4.6 && <5, hxt >= 9.3.1.2, template-haskell-                       , http-conduit, utf8-string, bytestring, vinyl >= 0.4+  build-depends:+      base >=4 && <5+    , bytestring+    , containers+    , directory+    , filepath+    , http-conduit+    , hxt >= 9.3.1.2+    , mtl+    , stm+    , template-haskell+    , transformers+    , utf8-string+    , vinyl >= 0.4  source-repository head   type:     git
src/HBooru/Network.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}+ -- | -- Module      :  HBooru.Network -- Copyright   :  (c) Mateusz Kowalczyk 2013-2014@@ -14,10 +18,18 @@ module HBooru.Network where  import Control.Applicative ((<$>))-import HBooru.Types-import Network.HTTP.Conduit (simpleHttp)-import Data.ByteString.Lazy (toStrict)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Error+import Data.ByteString.Lazy (toStrict, writeFile) import Data.ByteString.UTF8+import Data.Either (rights)+import HBooru.Parsers.Ichijou+import HBooru.Types+import Network.HTTP.Conduit (simpleHttp, HttpException(..))  -- | Given a 'Site', 'DataFormat' and a list of 'Tag's, naively fetch the first -- page or so and parse it to the appropriate image type. Both the site and the@@ -25,34 +37,38 @@ -- has to exist in an instance of 'CoerceResponse'. Uses 'fetchPostPage' to -- fetch the data. fetchTaggedPosts-  ∷ (Postable s d, CoerceResponse d r) ⇒ s → d → [Tag] → IO [ImageTy s d]+  ∷ (Postable s d, CoerceResponse d r) ⇒ s → d → [Tag] → ExcIO [ImageTy s d] fetchTaggedPosts s d ts = parseResponse s <$> fetchPostPage s d ts  -- | As 'fetchTaggedPosts' but works with sites which allow indexing by page. fetchTaggedPostsIndexed ∷ (CoerceResponse r a, PostablePaged s r)-                          ⇒ s → r → [Tag] → Integer → IO [ImageTy s r]+                          ⇒ s → r → [Tag] → Integer → ExcIO [ImageTy s r] fetchTaggedPostsIndexed s d ts i =   parseResponse s <$> fetchPostPageIndexed s d ts i  -- | Given an instance of 'Postable', 'CoerceResponse', and a list of 'Tag's, -- fetch the post page.-fetchPostPage ∷ (Postable s d, CoerceResponse d r) ⇒ s → d → [Tag] → IO r+fetchPostPage ∷ (Postable s d, CoerceResponse d r) ⇒ s → d → [Tag] → ExcIO r fetchPostPage s d ts = fetchResponse (postUrl s d ts) d  -- | Given an instance of 'Postable', 'CoerceResponse', and a list of 'Tag's, -- fetch the post page. fetchPostPageIndexed ∷ (PostablePaged s d, CoerceResponse d r)-                       ⇒ s → d → [Tag] → Integer → IO r+                       ⇒ s → d → [Tag] → Integer → ExcIO r fetchPostPageIndexed s d ts i = fetchResponse (postUrlPaged s d ts i) d  -- | Given a URL and protocol, tries to fetch a response.-fetchResponse ∷ CoerceResponse r r' ⇒ String → r → IO r'-fetchResponse u r = toResponse r . toString . toStrict <$> simpleHttp u+fetchResponse ∷ CoerceResponse r r' ⇒ String → r → ExcIO r'+fetchResponse u r = do+  liftIO (try (simpleHttp u)) >>= \case+    Left (e ∷ HttpException) → throwError $ Network e+    Right x → return . toResponse r . toString . toStrict $ x  -- | Uses 'fetchPostPage' to parse the number of posts available based on -- provided 'Tag's. fetchPostCount-  ∷ (Postable s r, Counted s r, CoerceResponse r a) ⇒ s → r → [Tag] → IO Integer+  ∷ (Postable s r, Counted s r, CoerceResponse r a) ⇒ s → r → [Tag]+  → ExcIO Integer fetchPostCount s d ts = parseCount s <$> fetchPostPage s d ts  -- | Attemps to fetch all posts from a site, from all its pages. The@@ -60,8 +76,48 @@ fetchAllTaggedPosts   ∷ (CoerceResponse r a, PostablePaged s r) ⇒ s → r → [Tag] → IO [ImageTy s r] fetchAllTaggedPosts s r ts = do-  count ← fromIntegral <$> fetchPostCount s r ts-  let pages = case hardLimit s r of-        NoLimit → 0-        Limit x → max 0 (ceiling $ (count / fromIntegral x) - 1)-  concat <$> mapM (fetchTaggedPostsIndexed s r ts) [0 .. pages]+  runErrorT (fetchPostCount s r ts) >>= \case+    Left e → print e >> return []+    Right i → do+      let count = fromIntegral i ∷ Double+          pages = case hardLimit s r of+            NoLimit → 0+            Limit x → max 0 (ceiling $ (count / fromIntegral x) - 1)+      r' ← mapM (runErrorT . fetchTaggedPostsIndexed s r ts) [0 .. pages]+      return . concat $ rights r'++data DownloadStatus = OK String+                    | Failed (Either HttpException IOException, String)+                    | EndOfQueue+                    deriving Show++-- | Downloads the given files. Writes the status information back to+-- the provided TChan.+downloadFiles ∷ [(String, FilePath)] -- ^ URL with save location+              → TChan DownloadStatus -- ^ Channel to send back status info on+              → Int -- ^ Max threads to run at once. Bounded to minimum of 1.+              → IO ()+downloadFiles ts ds mt = do+  tv ← atomically $ newTVar ts+  count ← atomically $ newTVar (0 ∷ Int)+  let maxThreads = max 1 mt+      wf x = x `seq` Data.ByteString.Lazy.writeFile x+      modCount f = atomically $ modifyTVar count (\x -> max 0 (f x))+      runDownload (url, path) =+        try (simpleHttp url) >>= \case+          Left (e ∷ HttpException) →+            atomically . writeTChan ds $ Failed (Left e, url)+          Right c → try (wf path c) >>= atomically . \case+            Left (e ∷ IOException) → writeTChan ds $ Failed (Right e, url)+            Right _ → writeTChan ds $ OK url+      readVs = atomically $ liftM2 (,) (readTVar tv) (readTVar count)+      spawnThreads = readVs >>= \case+        ([], 0) → atomically $ writeTChan ds EndOfQueue+        (ys, n) | n >= maxThreads → spawnThreads+                | otherwise → case ys of+                  [] → threadDelay 10000 >> spawnThreads+                  x:xs → void $ do+                    atomically (writeTVar tv xs)+                    forkIO $ modCount succ >> runDownload x >> modCount pred+                    spawnThreads+  spawnThreads
+ src/HBooru/Parsers/FieldParsers.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  HBooru.Parsers.FieldParsers+-- Copyright   :  (c) Mateusz Kowalczyk 2014+-- License     :  GPL-3+--+-- Maintainer  :  fuuzetsu@fuuzetsu.co.uk+-- Stability   :  experimental+--+-- A collection of arrow parsers for known fields. We can use these+-- (and write new ones) by composing these parsers together for each site we+-- want to parse. As we carry the field information with us, this can later be+-- used when trying to extract the parsed information from the sites into a+-- homogenous list. Currently this moduel only deals with parsing out XML+-- attributes.+module HBooru.Parsers.FieldParsers where++import Control.Applicative+import Control.Exception.Base (Exception)+import Control.Monad+import Control.Monad.Error+import Data.Maybe+import Data.Monoid+import Data.Typeable+import Data.Vinyl+import HBooru.Types+import Prelude+import Text.Read (readMaybe)+import Text.XML.HXT.Core hiding (mkName, (<+>))++import Data.Vinyl.TyFun++newtype E = E String deriving (Show, Eq, Typeable)+instance Exception E where++-- | Alias for the common constraint blob+type ParseArrow cat = (Functor (cat XmlTree), ArrowXml cat)++-- | Alias for named fields+type Field cat s = cat XmlTree (Parse (R '[s]))++-- | Helper that provides better error messages when a 'read' fails.+readAttr ∷ (ArrowXml cat, Read (App ElF s), Functor (cat XmlTree)) ⇒ String+         → sing s → Field cat s+readAttr s f = readAttrWith s f readMaybe++readAttrWith ∷ (ArrowXml cat, Functor (cat XmlTree)) ⇒ String → sing s+             → (String → Maybe (App ElF s)) → Field cat s+readAttrWith s f r = readCustom s f (\x → handler x $ r x)+  where+    handler inp Nothing = throwError . PF $ mconcat [s, ": '", inp, "'"]+    handler _ (Just x) = return x++readCustom ∷ (ArrowXml cat, Functor (cat XmlTree)) ⇒ String+           → sing s → (String → Parse (App ElF s)) → Field cat s+readCustom s f h = fmap (f =:) . h <$> getAttrValue s++readNormalAttr ∷ (ArrowXml cat, (App ElF s) ~ String, Functor (cat XmlTree))+               ⇒ String → sing s → Field cat s+readNormalAttr s f = return . (f =:) <$> getAttrValue s++-- * Individual attribute parsers++-- | Parser arrow for a "height" XML attribute.+heightA ∷ ParseArrow cat ⇒ Field cat "height"+heightA = readAttr "height" height++-- | Parser arrow for a "score" XML attribute.+scoreA ∷ ParseArrow cat ⇒ Field cat "score"+scoreA = readAttr "score" score++-- | Parser arrow for a "file_url" XML attribute.+file_urlA ∷ ParseArrow cat ⇒ Field cat "file_url"+file_urlA = readNormalAttr "file_url" file_url++-- | Parser arrow for a "parent_id" XML attribute.+parent_idA ∷ ParseArrow cat ⇒ Field cat "parent_id"+parent_idA = readCustom "parent_id" parent_id handler+  where+    handler = return . readMaybe++-- | Parser arrow for a "sample_url" XML attribute.+sample_urlA ∷ ParseArrow cat ⇒ Field cat "sample_url"+sample_urlA = readNormalAttr "sample_url" sample_url++-- | Parser arrow for a "sample_width" XML attribute.+sample_widthA ∷ ParseArrow cat ⇒ Field cat "sample_width"+sample_widthA = readAttr "sample_width" sample_width++-- | Parser arrow for a "sample_height" XML attribute.+sample_heightA ∷ ParseArrow cat ⇒ Field cat "sample_height"+sample_heightA = readAttr "sample_height" sample_height++-- | Parser arrow for a "preview_url" XML attribute.+preview_urlA ∷ ParseArrow cat ⇒ Field cat "preview_url"+preview_urlA = readNormalAttr "preview_url" preview_url++-- | Parser arrow for a "rating" XML attribute.+ratingA ∷ ParseArrow cat ⇒ Field cat "rating"+ratingA = readAttrWith "rating" rating parseRating++-- | Parser arrow for a "tags" XML attribute.+tagsA ∷ ParseArrow cat ⇒ Field cat "tags"+tagsA = readCustom "tags" tags (return . parseTags)++-- | Parser arrow for a "id" XML attribute.+idA ∷ ParseArrow cat ⇒ Field cat "id"+idA = readAttr "id" HBooru.Types.id++-- | Parser arrow for a "width" XML attribute.+widthA ∷ ParseArrow cat ⇒ Field cat "width"+widthA = readAttr "width" width++-- | Parser arrow for a "change" XML attribute.+changeA ∷ ParseArrow cat ⇒ Field cat "change"+changeA = readAttr "change" change++-- | Parser arrow for a "md5" XML attribute.+md5A ∷ ParseArrow cat ⇒ Field cat "md5"+md5A = readNormalAttr "md5" md5++-- | Parser arrow for a "creator_id" XML attribute.+creator_idA ∷ ParseArrow cat ⇒ Field cat "creator_id"+creator_idA = readAttr "creator_id" creator_id++-- | Parser arrow for a "has_children" XML attribute.+has_childrenA ∷ ParseArrow cat ⇒ Field cat "has_children"+has_childrenA = readAttrWith "has_children" has_children parseBool++-- | Parser arrow for a "created_at" XML attribute.+created_atA ∷ ParseArrow cat ⇒ Field cat "created_at"+created_atA = readNormalAttr "created_at" created_at++-- | Parser arrow for a "status" XML attribute.+statusA ∷ ParseArrow cat ⇒ Field cat "status"+statusA = readNormalAttr "status" status++-- | Parser arrow for a "source" XML attribute.+sourceA ∷ ParseArrow cat ⇒ Field cat "source"+sourceA = readNormalAttr "source" source++-- | Parser arrow for a "has_notes" XML attribute.+has_notesA ∷ ParseArrow cat ⇒ Field cat "has_notes"+has_notesA = readAttrWith "has_notes" has_notes (return . parseBool)++-- | Parser arrow for a "has_comments" XML attribute.+has_commentsA ∷ ParseArrow cat ⇒ Field cat "has_comments"+has_commentsA = readAttrWith "has_comments" has_comments (return . parseBool)++-- | Parser arrow for a "preview_width" XML attribute.+preview_widthA ∷ ParseArrow cat ⇒ Field cat "preview_width"+preview_widthA = readAttr "preview_width" preview_width++-- | Parser arrow for a "preview_height" XML attribute.+preview_heightA ∷ ParseArrow cat ⇒ Field cat "preview_height"+preview_heightA = readAttr "preview_height" preview_height++-- | Parser arrow for a "author" XML attribute.+authorA ∷ ParseArrow cat ⇒ Field cat "author"+authorA = readNormalAttr "author" author++-- | Parser arrow for a "actual_preview_height" XML attribute.+actual_preview_heightA ∷ ParseArrow cat ⇒ Field cat "actual_preview_height"+actual_preview_heightA = readAttr "actual_preview_height" actual_preview_height++-- | Parser arrow for a "actual_preview_width" XML attribute.+actual_preview_widthA ∷ ParseArrow cat ⇒ Field cat "actual_preview_width"+actual_preview_widthA = readAttr "actual_preview_width" actual_preview_width++-- | Parser arrow for a "frames" XML attribute.+framesA ∷ ParseArrow cat ⇒ Field cat "frames"+framesA = readNormalAttr "frames" frames++-- | Parser arrow for a "frames_pending" XML attribute.+frames_pendingA ∷ ParseArrow cat ⇒ Field cat "frames_pending"+frames_pendingA = readNormalAttr "frames_pending" frames_pending++-- | Parser arrow for a "frames_pending_string" XML attribute.+frames_pending_stringA ∷ ParseArrow cat ⇒ Field cat "frames_pending_string"+frames_pending_stringA =+  readNormalAttr "frames_pending_string" frames_pending_string++-- | Parser arrow for a "frames_string" XML attribute.+frames_stringA ∷ ParseArrow cat ⇒ Field cat "frames_string"+frames_stringA = readNormalAttr "frames_string" frames_string++-- | Parser arrow for a "is_held" XML attribute.+is_heldA ∷ ParseArrow cat ⇒ Field cat "is_held"+is_heldA = readAttrWith "is_held" is_held parseBool++-- | Parser arrow for a "is_shown_in_index" XML attribute.+is_shown_in_indexA ∷ ParseArrow cat ⇒ Field cat "is_shown_in_index"+is_shown_in_indexA =+  readAttrWith "is_shown_in_index" is_shown_in_index parseBool++-- | Parser arrow for a "jpeg_file_size" XML attribute.+jpeg_file_sizeA ∷ ParseArrow cat ⇒ Field cat "jpeg_file_size"+jpeg_file_sizeA = readAttr "jpeg_file_size" jpeg_file_size++-- | Parser arrow for a "jpeg_height" XML attribute.+jpeg_heightA ∷ ParseArrow cat ⇒ Field cat "jpeg_height"+jpeg_heightA = readAttr "jpeg_height" jpeg_height++-- | Parser arrow for a "jpeg_url" XML attribute.+jpeg_urlA ∷ ParseArrow cat ⇒ Field cat "jpeg_url"+jpeg_urlA = readNormalAttr "jpeg_url" jpeg_url++-- | Parser arrow for a "jpeg_width" XML attribute.+jpeg_widthA ∷ ParseArrow cat ⇒ Field cat "jpeg_width"+jpeg_widthA = readAttr "jpeg_width" jpeg_width++-- | Parser arrow for a "sample_file_size" XML attribute.+sample_file_sizeA ∷ ParseArrow cat ⇒ Field cat "sample_file_size"+sample_file_sizeA = readAttr "sample_file_size" sample_file_size++-- | Parser arrow for a "file_size" XML attribute.+file_sizeA ∷ ParseArrow cat ⇒ Field cat "file_size"+file_sizeA = readAttr "file_size" file_size++-- * Parsing helpers++-- | Parses a string returned from a Gelbooru-like site into+-- one of the commonly used 'Rating's. Note that this is a partial function+-- so you should make sure that the site in question only ever returns the+-- values in a format specified in the function+parseRating ∷ String → Maybe Rating+parseRating "e" = Just Explicit+parseRating "s" = Just HBooru.Types.Safe+parseRating "q" = Just Questionable+parseRating _ = Nothing++-- | Splits returned tag string into separate 'Tag's. For Gelbooru-like+-- sites, this is just the question of splitting on whitespace.+parseTags ∷ String → [Tag]+parseTags = words++-- | Reads a lowercase 'Bool' string representation into its Haskell type. If we+-- can't parse the boolean, return 'Nothing'.+parseBool ∷ String → Maybe Bool+parseBool "false" = Just False+parseBool "true" = Just True+parseBool _ = Nothing++infixr 5 <:+>+-- | A little helper that lifts '<+>' into 'Arrow' which allows us to+-- compose parsers returning records very easily.+(<:+>) ∷ Arrow cat ⇒ cat b (Parse (R as))+       → cat b (Parse (R bs))+       → cat b (Parse (R (as ++ bs)))+x <:+> y = arr (uncurry pnd) <<< x &&& y+  where+    pnd ∷ Parse (R a) → Parse (R b) → Parse (R (a ++ b))+    pnd (Left x') _ = Left x'+    pnd _ (Left y') = Left y'+    pnd (Right x') (Right y') = Right (x' <+> y')
src/HBooru/Parsers/Gelbooru.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Parsers.Gelbooru@@ -16,13 +16,12 @@ module HBooru.Parsers.Gelbooru where  import Data.List-import Data.Vinyl import HBooru.Parsers.FieldParsers import HBooru.Types import Text.XML.HXT.Core hiding (mkName)  -- | Record used for Gelbooru posts-type GelbooruPost = R+type GelbooruPost = PR   '[ "height"    , "score"    , "file_url"@@ -59,7 +58,7 @@  -- | We use this type and its 'Site' instance to distinguish -- between various parsers.-data Gelbooru = Gelbooru+data Gelbooru = Gelbooru deriving (Show, Eq)  instance Postable Gelbooru XML where   postUrl _ _ ts =
src/HBooru/Parsers/Ichijou.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Parsers.Ichijou@@ -16,17 +16,16 @@ module HBooru.Parsers.Ichijou where  import Data.List-import Data.Vinyl import HBooru.Parsers.FieldParsers import HBooru.Types import Text.XML.HXT.Core hiding (mkName)  -- | We use this type and its 'Site' instance to distinguish -- between various parsers.-data Ichijou = Ichijou+data Ichijou = Ichijou deriving (Show, Eq)  -- | Ichijou post record alias-type IchijouPost = R+type IchijouPost = PR   '[ "creator_id"    , "md5"    , "status"
src/HBooru/Parsers/Konachan.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Parsers.Konachan@@ -17,17 +17,16 @@ module HBooru.Parsers.Konachan where  import Data.List-import Data.Vinyl import HBooru.Parsers.FieldParsers import HBooru.Types import Text.XML.HXT.Core hiding (mkName)  -- | We use this type and its 'Site' instance to distinguish -- between various parsers.-data Konachan = Konachan+data Konachan = Konachan deriving (Show, Eq)  -- | Konachan post record-type KonachanPost = R+type KonachanPost = PR   '[ "actual_preview_height"    , "actual_preview_width"    , "author"
src/HBooru/Parsers/Safebooru.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Parsers.Safebooru@@ -16,17 +16,16 @@ module HBooru.Parsers.Safebooru where  import Data.List-import Data.Vinyl import HBooru.Parsers.FieldParsers import HBooru.Types import Text.XML.HXT.Core hiding (mkName)  -- | We use this type and its 'Site' instance to distinguish -- between various parsers.-data Safebooru = Safebooru+data Safebooru = Safebooru deriving (Show, Eq)  -- | Safebooru post record.-type SafebooruPost = R+type SafebooruPost = PR   '[ "height"    , "score"    , "file_url"
src/HBooru/Parsers/Yandere.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Parsers.Yandere@@ -13,21 +13,20 @@ -- Stability   :  experimental -- -- Module for parsing content from <http://yande.re/ Yandere>,--- known in the past as <http://mou.imouto.org MouImouto>.+-- known in the past as <http://moe.imouto.org MoeImouto>. module HBooru.Parsers.Yandere where  import Data.List-import Data.Vinyl import HBooru.Parsers.FieldParsers import HBooru.Types import Text.XML.HXT.Core hiding (mkName)  -- | We use this type and its 'Site' instance to distinguish -- between various parsers.-data Yandere = Yandere+data Yandere = Yandere deriving (Show, Eq)  -- | Alias for a record representing typical Yandere post.-type YanderePost = R+type YanderePost = PR   '[ "actual_preview_height"    , "actual_preview_width"    , "author"
src/HBooru/Types.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK show-extensions #-}  -- | -- Module      :  HBooru.Types@@ -18,11 +18,17 @@ -- Module definining types used by the library. module HBooru.Types where +import Control.Arrow+import Control.Applicative+import Control.Monad+import Control.Exception+import Control.Monad.Error import Data.Proxy import GHC.TypeLits (Symbol) import Data.Vinyl import Data.Vinyl.TH-import Prelude hiding (id)+import Network.HTTP.Conduit (HttpException(..))+import Prelude import Text.XML.HXT.Core hiding (mkName, (<+>))  -- | Tags used for searching in sites. No special escaping is done.@@ -168,10 +174,41 @@ instance Response JSONResponse where   getResponse (JSONResponse x) = x - instance Functor (LA XmlTree) where   fmap f (LA g) = LA $ fmap fmap fmap f g +bA ∷ ArrowApply cat ⇒ cat c' b → (b → cat c' c) → cat c' c+bA mx f = (arr (\a -> mx >>> arr (\x -> (f x, a)) >>> app) &&& arr id) >>> app++instance Applicative (LA XmlTree) where+  pure x = LA . const $ return x+  (<*>) = ap++instance Monad (LA XmlTree) where+  return = pure+  (>>=) = bA++-- | Parse failures from various parsers+newtype ParseFailure = PF String deriving (Show, Eq)++instance Error ParseFailure where+  noMsg = PF noMsg+  strMsg = PF . strMsg++-- | Alias for our parser monad with failure possibility+type Parse = Either ParseFailure++data RealWorldExcs = Network HttpException+                   | IOE IOException+                   | SomethingElse String+                   deriving (Show)++instance Error RealWorldExcs where+  noMsg = SomethingElse noMsg+  strMsg = SomethingElse . strMsg++type ExcIO a = ErrorT RealWorldExcs IO a+ makeUniverse' ''Symbol "ElF" semantics ''ElF [ [t| "height" |]                :~> [t| Integer |]                 , [t| "score" |]                 :~> [t| Integer |]@@ -184,8 +221,8 @@                 , [t| "rating" |]                :~> [t| Rating |]                 , [t| "tags" |]                  :~> [t| [Tag] |]                 , [t| "id" |]                    :~> [t| Integer |]-                , [t| "width" |]                 :~> [t| String |]-                , [t| "change" |]                :~> [t| String |]+                , [t| "width" |]                 :~> [t| Integer |]+                , [t| "change" |]                :~> [t| Int |]                 , [t| "md5" |]                   :~> [t| String |]                 , [t| "creator_id" |]            :~> [t| Integer |]                 , [t| "has_children" |]          :~> [t| Bool |]@@ -215,6 +252,9 @@  -- | Handy synonym hiding 'ElF'. type R a = PlainRec ElF a++-- | 'R' wrapped in a 'Parse'.+type PR a = Parse (R a)  -- * Commonly used fields
src/Main.hs view
@@ -1,9 +1,16 @@ {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} module Main where  import Control.Applicative ((<$>))-import Data.Vinyl+import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Monad (void, filterM)+import Data.Map+import Data.Monoid+import Data.Vinyl (rGet) import HBooru.Network import HBooru.Parsers.Gelbooru import HBooru.Parsers.Ichijou@@ -11,27 +18,76 @@ import HBooru.Parsers.Safebooru import HBooru.Parsers.Yandere import HBooru.Types+import System.Directory import System.Environment (getArgs)+import System.Exit+import System.FilePath  main ∷ IO () main = getArgs >>= \case-  [] → putStrLn help-  xs → fetchImageLinks xs >>= mapM_ putStrLn+  [] → putStr help+  "-d":d:ts → downloadTo d ts+  xs → fetchImageLinks xs >>= \x → mapM_ putStrLn [ y | Right y ← x ] -fetchImageLinks ∷ [Tag] → IO [String]+-- | Downloads all the images with the given tag to the given+-- directory.+downloadTo ∷ FilePath → [Tag] → IO ()+downloadTo fp xs = doesDirectoryExist fp >>= \case+  False → print (fp <> " doesn't exist.") >> exitFailure+  True → do+    let f p = run <$> fetchAllTaggedPosts p XML xs+          where+            run s =+              fromList [ (md5 `rGet` r, file_url `rGet` r) | Right r ← s ]+    g ← f Gelbooru+    i ← f Ichijou+    k ← f Konachan+    s ← f Safebooru+    y ← f Yandere+    let ls = g <> i <> k <> s <> y+        mkFp (m, u) = let e = snd $ splitExtension u+                      in fp </> m <.> e+    dcs ← Prelude.map (fp </>) <$> getDirectoryContents fp+    let notInFiles = (`notElem` dcs) . snd+        fs = Prelude.filter notInFiles [ (snd x, mkFp x) | x ← assocs ls ]+        lfs = show $ length fs+    ds ← atomically newTChan+    got ← newTVarIO 0+    let loop = atomically (readTChan ds) >>= \case+          EndOfQueue → putStrLn "Done."+          x → do+            v ← atomically $ modifyTVar got succ >> readTVar got+            putStrLn (concat ["(", show v, "/", lfs, "): ", show x]) >> loop++    void . forkIO $ downloadFiles fs ds 5+    loop+++-- | Fetches a map of images, with keys being the md5 and values being+-- URLs.+fetchImageLinks ∷ [Tag] → IO [Parse String] fetchImageLinks xs = do-  let f p = map (file_url `rGet`) <$> fetchAllTaggedPosts p XML xs+  let f p = Prelude.map getInfo <$> fetchAllTaggedPosts p XML xs+        where+          getInfo (Left (PF m)) = Left . PF $ unwords [show p, m]+          getInfo (Right r) = return $ file_url `rGet` r   g ← f Gelbooru   i ← f Ichijou   k ← f Konachan   s ← f Safebooru   y ← f Yandere-  let ls = g ++ i ++ k ++ s ++ y+  let ls = g <> i <> k <> s <> y   return $ length ls `seq` ls  help ∷ String help = unlines $-       [ "Usage: h-booru tag1 [tag2] … [tagn]"-       , ""-       , "Prints a list of links matching the tags"-       ]+  [ "Usage: h-booru tag1 [tag2] … [tagN]"+  , ""+  , "Prints a list of links matching the tags"+  , ""+  , "h-booru -d DIRECTORY tag1 [tag2] … [tagN]"+  , ""+  , "Downloads the files with the given tags to the given directory."+  , "Naming scheme is md5.originalextension"+  , "The dowloader will skip files it already sees downloaded, by filename."+  ]