packages feed

h-booru 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+603/−337 lines, 11 filesdep +bytestringdep +http-conduitdep +utf8-stringnew-component:exe:h-booru

Dependencies added: bytestring, http-conduit, utf8-string, vinyl

Files

h-booru.cabal view
@@ -1,5 +1,5 @@ name:                h-booru-version:             0.1.0.0+version:             0.2.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@@ -23,12 +23,31 @@   default-language:    Haskell2010   exposed-modules:     HBooru.Types+    HBooru.Network     HBooru.Parsers.Gelbooru     HBooru.Parsers.Ichijou     HBooru.Parsers.Konachan     HBooru.Parsers.Safebooru     HBooru.Parsers.Yandere-    HBooru.Parsers.GenericBooru-    HBooru.Parsers.GenericBooru.TH-  -- other-modules:   build-depends:       base >=4.6 && <5, hxt >= 9.3.1.2, template-haskell+                       , http-conduit, utf8-string, bytestring, vinyl >= 0.4+++executable h-booru+  hs-source-dirs:      src+  default-language:    Haskell2010+  main-is: Main.hs+  other-modules:+    HBooru.Types+    HBooru.Network+    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++source-repository head+  type:     git+  location: https://github.com/Fuuzetsu/h-booru.git
+ src/HBooru/Network.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE UnicodeSyntax #-}+-- |+-- Module      :  HBooru.Network+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014+-- License     :  GPL-3+--+-- Maintainer  :  fuuzetsu@fuuzetsu.co.uk+-- Stability   :  experimental+--+-- Module providing functions to interface with some booru sites.+-- Amongst other things, it should (semi-transparently) handle post count+-- limits. The user should simply be able to ask for all images with certain+-- rather than worrying about hard limits per page set by the sites &c.+module HBooru.Network where++import Control.Applicative ((<$>))+import HBooru.Types+import Network.HTTP.Conduit (simpleHttp)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.UTF8++-- | 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+-- format need to together form an instance of 'Postable' and the data format+-- 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]+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]+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 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+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++-- | 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+fetchPostCount s d ts = parseCount s <$> fetchPostPage s d ts++-- | Attemps to fetch all posts from a site, from all its pages. The+-- upper limit of images per page is used.+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]
src/HBooru/Parsers/Gelbooru.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module      :  HBooru.Parsers.Gelbooru--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk@@ -15,33 +15,66 @@ -- Module for parsing content from <http://gelbooru.com/ Gelbooru>. module HBooru.Parsers.Gelbooru where -import           Data.List-import qualified HBooru.Parsers.GenericBooru as G-import           HBooru.Parsers.GenericBooru.TH (makePost)-import           HBooru.Types-import           Language.Haskell.TH (mkName)-import           Text.XML.HXT.Core hiding (mkName)+import Data.List+import Data.Vinyl+import HBooru.Parsers.FieldParsers+import HBooru.Types+import Text.XML.HXT.Core hiding (mkName) --- | Data type for Gelbooru posts generated using 'makePost'.-$(makePost (mkName "GelbooruPost"))+-- | Record used for Gelbooru posts+type GelbooruPost = R+  '[ "height"+   , "score"+   , "file_url"+   , "parent_id"+   , "sample_url"+   , "sample_width"+   , "sample_height"+   , "preview_url"+   , "rating"+   , "tags"+   , "id"+   , "width"+   , "change"+   , "md5"+   , "creator_id"+   , "has_children"+   , "created_at"+   , "status"+   , "source"+   , "has_notes"+   , "has_comments"+   , "preview_width"+   , "preview_height"+   ] +-- | XML parser for Gelbooru used by "Postable Gelbooru XML" instance.+parsePost ∷ (Functor (cat XmlTree), ArrowXml cat) ⇒ cat XmlTree GelbooruPost+parsePost = hasName "post"+  >>> heightA <:+> scoreA <:+> file_urlA <:+> parent_idA <:+> sample_urlA+  <:+> sample_widthA <:+> sample_heightA <:+> preview_urlA <:+> ratingA+  <:+> tagsA <:+> idA <:+> widthA <:+> changeA <:+> md5A <:+> creator_idA+  <:+> has_childrenA <:+> created_atA <:+> statusA <:+> sourceA <:+> has_notesA+  <:+> has_commentsA <:+> preview_widthA <:+> preview_heightA+ -- | We use this type and its 'Site' instance to distinguish -- between various parsers. data Gelbooru = Gelbooru  instance Postable Gelbooru XML where   postUrl _ _ ts =-    let tags = intercalate "+" ts+    let tags' = intercalate "+" ts     in "http://gelbooru.com/index.php?page=dapi&s=post&q=index&limit=100&tags="-       ++ tags ++ "&pid=0"-  hardLimit _ = Limit 100+       ++ tags'+  hardLimit _ _ = Limit 100 +instance PostablePaged Gelbooru XML+ instance Site Gelbooru where  instance PostParser Gelbooru XML where   type ImageTy Gelbooru XML = GelbooruPost-  parseResponse _ = map (`betweenPosts` GelbooruPost)-                    . runLA (xreadDoc /> G.parsePost) . getResponse+  parseResponse _ = runLA (xreadDoc /> parsePost) . getResponse  instance Counted Gelbooru XML where   parseCount _ = read . head . runLA (xreadDoc >>> hasName "posts"
− src/HBooru/Parsers/GenericBooru.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE TemplateHaskell #-}--- |--- Module      :  HBooru.Parsers.GenericBooru--- Copyright   :  (c) Mateusz Kowalczyk 2013--- License     :  GPL-3------ Maintainer  :  fuuzetsu@fuuzetsu.co.uk--- Stability   :  experimental------ | Many booru sites use the same engine (Gelbooru engine) so instead of having--- identical parsers across many modules, we simply alias our 'GenericPost' to--- whatever we need.-module HBooru.Parsers.GenericBooru where--import Prelude hiding (id)-import Data.String-import HBooru.Types-import HBooru.Parsers.GenericBooru.TH-import Text.Read (readMaybe)-import Text.XML.HXT.Core hiding (mkName)-import Language.Haskell.TH (mkName)---- | A post we might expect from many of the sites as a lot of them seem to be--- based on the Gelbooru engine.-$(makePost (mkName "GenericPost"))---- | Fairly naïve parser for all attributes in sites running vanilla--- Gelbooru engine. While it catches all attributes in a typical XML post--- result, we trust that they are consistent and use 'read' to deserialise some--- values. For sites with non-default replies, custom parsers have to be written.-parsePost ∷ ArrowXml cat ⇒ cat XmlTree GenericPost-parsePost = hasName "post" >>> proc x → do-  height <- getAttrValue "height" -< x-  score <- getAttrValue "score" -< x-  file_url <- getAttrValue "file_url" -< x-  parent_id <- getAttrValue "parent_id" -< x-  sample_url <- getAttrValue "sample_url" -< x-  sample_width <- getAttrValue "sample_width" -< x-  sample_height <- getAttrValue "sample_height" -< x-  preview_url <- getAttrValue "preview_url" -< x-  rating <- getAttrValue "rating" -< x-  tags <- getAttrValue "tags" -< x-  id <- getAttrValue "id" -< x-  width <- getAttrValue "width" -< x-  change <- getAttrValue "change" -< x-  md5 <- getAttrValue "md5" -< x-  creator_id <- getAttrValue "creator_id" -< x-  has_children <- getAttrValue "has_children" -< x-  created_at <- getAttrValue "created_at" -< x-  status <- getAttrValue "status" -< x-  source <- getAttrValue "source" -< x-  has_notes <- getAttrValue "has_notes" -< x-  has_comments <- getAttrValue "has_comments" -< x-  preview_width <- getAttrValue "preview_width" -< x-  preview_height <- getAttrValue "preview_height" -< x-  returnA -< GenericPost-      { heightT = read height-      , scoreT = read score-      , file_urlT = file_url-      , parent_idT = readMaybe parent_id-      , sample_urlT = sample_url-      , sample_widthT = read sample_width-      , sample_heightT = read sample_height-      , preview_urlT = preview_url-      , ratingT = parseRating rating-      , tagsT = parseTags tags-      , idT = read id-      , widthT = read width-      , changeT = change-      , md5T = md5-      , creator_idT = read creator_id-      , has_childrenT = parseBool has_children-      , created_atT = created_at-      , statusT = status-      , sourceT = source-      , has_notesT = parseBool has_notes-      , has_commentsT = parseBool has_comments-      , preview_widthT = read preview_width-      , preview_heightT = read preview_height-      }---- | 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 -> Rating-parseRating "e" = Explicit-parseRating "s" = HBooru.Types.Safe-parseRating "q" = Questionable---- | 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
− src/HBooru/Parsers/GenericBooru/TH.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- |--- Module      :  HBooru.Parsers.GenericBooru.TH--- Copyright   :  (c) Mateusz Kowalczyk 2013--- License     :  GPL-3------ Maintainer  :  fuuzetsu@fuuzetsu.co.uk--- Stability   :  experimental------ | Helper module for "HBooru.Parsers.GenericBooru" due to Template Haskell--- limitation of being unable to splice inside of the same module of--- definitions.-module HBooru.Parsers.GenericBooru.TH where--import Control.Applicative-import HBooru.Types-import Language.Haskell.TH-import Language.Haskell.TH.Syntax---- | A TH helper which makes an instance along with the data type using--- 'makePost'' and 'makePostInstance'.-makePost n = liftA2 (++) (makePost' n) (makePostInstance n)---- | Template Haskell function which is able to generate 'GenericPost'-alike--- type declarations for cases where we want to use this format but need a--- different data type. It can be used by using @TemplateHaskell@ extension and--- calling @$(makePost ('mkName' \"YourTypeName\"))@ at the top level. Hopefully--- a temporary measure until the author thinks of a better way to provide--- generic Gelbooru-like post parsing while casting out to different data types--- that's OK to write.-makePost' :: Name -> Q [Dec]-makePost' n =-  fmap (:[]) $ dataD (cxt []) n []-  [ recC n-    [ varStrictType (mkName "heightT") $ strictType notStrict [t| Integer |]-    , varStrictType (mkName "scoreT") $ strictType notStrict [t| Integer |]-    , varStrictType (mkName "file_urlT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "parent_idT") $ strictType notStrict-                                             [t| Maybe Integer |]-    , varStrictType (mkName "sample_urlT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "sample_widthT") $ strictType notStrict-                                                [t| Integer |]-    , varStrictType (mkName "sample_heightT") $ strictType notStrict-                                                 [t| Integer |]-    , varStrictType (mkName "preview_urlT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "ratingT") $ strictType notStrict [t| Rating |]-    , varStrictType (mkName "tagsT") $ strictType notStrict [t| [String] |]-    , varStrictType (mkName "idT") $ strictType notStrict [t| Integer |]-    , varStrictType (mkName "widthT") $ strictType notStrict [t| Integer |]-    , varStrictType (mkName "changeT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "md5T") $ strictType notStrict [t| String |]-    , varStrictType (mkName "creator_idT") $ strictType notStrict [t| Integer |]-    , varStrictType (mkName "has_childrenT") $ strictType notStrict-                                                [t| Maybe Bool |]-    , varStrictType (mkName "created_atT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "statusT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "sourceT") $ strictType notStrict [t| String |]-    , varStrictType (mkName "has_notesT") $ strictType notStrict-                                             [t| Maybe Bool |]-    , varStrictType (mkName "has_commentsT") $ strictType notStrict-                                                [t| Maybe Bool |]-    , varStrictType (mkName "preview_widthT") $ strictType notStrict-                                                 [t| Integer |]-    , varStrictType (mkName "preview_heightT") $ strictType notStrict-                                                 [t| Integer |]-    ]-  ] [mkName "Show", mkName "Eq"]---- | Template Haskell function which creates 'Post' instances for things made--- with 'makePost'.-makePostInstance :: Name -> Q [Dec]-makePostInstance n = do-  return [InstanceD-          []-          (ConT (mkName "Post") `AppT` ConT n)-          [ onG "height", onG "score", onG "file_url", onG "parent_id"-          , onG "sample_url", onG "sample_width", onG "sample_height"-          , onG "preview_url", onG "rating", onG "tags", onG "id"-          , onG "width", onG "change", onG "md5", onG "creator_id"-          , onG "has_children", onG "created_at", onG "status"-          , onG "source", onG "has_notes", onG "has_comments"-          , onG "preview_width", onG "preview_height"-          ]-         ]-    where-      onG n = FunD (mkName n)-              [ Clause [(VarP (mkName "g"))]-                (NormalB (AppE (VarE (mkName $ n ++ "T"))-                          (VarE (mkName "g")))) []-              ]
src/HBooru/Parsers/Ichijou.hs view
@@ -1,46 +1,82 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}  -- | -- Module      :  HBooru.Parsers.Ichijou--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk -- Stability   :  experimental ----- Module for parsing content from <http://safebooru.org/ safebooru>.+-- Module for parsing content from <http://ichijou.org/ Ichijou/vectorbooru>. module HBooru.Parsers.Ichijou where -import           Data.List-import qualified HBooru.Parsers.GenericBooru as G-import           HBooru.Parsers.GenericBooru.TH (makePost)-import           HBooru.Types-import           Language.Haskell.TH.Syntax (mkName)-import           Text.XML.HXT.Core hiding (mkName)---- | Data type for safebooru posts generated using 'makePost'.-$(makePost (mkName "IchijouPost"))+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 +-- | Ichijou post record alias+type IchijouPost = R+  '[ "creator_id"+   , "md5"+   , "status"+   , "preview_height"+   , "has_notes"+   , "author"+   , "source"+   , "score"+   , "file_size"+   , "sample_width"+   , "width"+   , "file_url"+   , "sample_height"+   , "has_children"+   , "tags"+   , "change"+   , "preview_url"+   , "has_comments"+   , "id"+   , "sample_url"+   , "rating"+   , "created_at"+   , "preview_width"+   , "parent_id"+   , "height"+   ]++-- | Parser arrow used for Ichijou.+parsePost ∷ (Functor (cat XmlTree), ArrowXml cat) ⇒ cat XmlTree IchijouPost+parsePost = hasName "post"+  >>> creator_idA <:+> md5A <:+> statusA <:+> preview_heightA <:+> has_notesA+  <:+> authorA <:+> sourceA <:+> scoreA <:+> file_sizeA <:+> sample_widthA+  <:+> widthA <:+> file_urlA <:+> sample_heightA <:+> has_childrenA <:+> tagsA+  <:+> changeA <:+> preview_urlA <:+> has_commentsA <:+> idA <:+> sample_urlA+  <:+> ratingA <:+> created_atA <:+> preview_widthA <:+> parent_idA <:+> heightA+ instance Postable Ichijou XML where   postUrl _ _ ts =-    let tags = intercalate "+" ts-    in "http://ichijou.org/index.xml?tags=" ++ tags-  hardLimit _ = Limit 100+    let tags' = intercalate "+" ts+    in "http://ichijou.org/post/index.xml?tags=" ++ tags'+  hardLimit _ _ = Limit 1000 +instance PostablePaged Ichijou XML where+  postUrlPaged s r ts i = postUrl s r ts ++ "&page=" ++ show (i + 1)+ instance Site Ichijou where  instance PostParser Ichijou XML where   type ImageTy Ichijou XML = IchijouPost-  parseResponse _ = map (`betweenPosts` IchijouPost)-                    . runLA (xreadDoc /> G.parsePost) . getResponse+  parseResponse _ = runLA (xreadDoc /> parsePost) . getResponse  instance Counted Ichijou XML where   parseCount _ = read . head . runLA (xreadDoc >>> hasName "posts"
src/HBooru/Parsers/Konachan.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module      :  HBooru.Parsers.Konachan--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk@@ -16,32 +16,82 @@  module HBooru.Parsers.Konachan where -import           Data.List-import qualified HBooru.Parsers.GenericBooru as G-import           HBooru.Parsers.GenericBooru.TH (makePost)-import           HBooru.Types-import           Language.Haskell.TH (mkName)-import           Text.XML.HXT.Core hiding (mkName)---- | Data type for Konachan posts generated using 'makePost'.-$(makePost (mkName "KonachanPost"))+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 +-- | Konachan post record+type KonachanPost = R+  '[ "actual_preview_height"+   , "actual_preview_width"+   , "author"+   , "change"+   , "created_at"+   , "file_size"+   , "file_url"+   , "frames"+   , "frames_pending"+   , "frames_pending_string"+   , "frames_string"+   , "has_children"+   , "height"+   , "id"+   , "is_held"+   , "is_shown_in_index"+   , "jpeg_file_size"+   , "jpeg_height"+   , "jpeg_url"+   , "jpeg_width"+   , "md5"+   , "preview_height"+   , "preview_url"+   , "preview_width"+   , "rating"+   , "sample_file_size"+   , "sample_height"+   , "sample_url"+   , "sample_width"+   , "score"+   , "source"+   , "status"+   , "tags"+   , "width"+   ]++-- | Parser arrow used for Konachan.+parsePost ∷ (Functor (cat XmlTree), ArrowXml cat) ⇒ cat XmlTree KonachanPost+parsePost = hasName "post"+  >>> actual_preview_heightA <:+> actual_preview_widthA <:+> authorA+  <:+> changeA  <:+> created_atA <:+> file_sizeA <:+> file_urlA+  <:+> framesA <:+> frames_pendingA <:+> frames_pending_stringA+  <:+> frames_stringA <:+> has_childrenA+  <:+> heightA <:+> idA <:+> is_heldA <:+> is_shown_in_indexA+  <:+> jpeg_file_sizeA <:+> jpeg_heightA <:+> jpeg_urlA <:+> jpeg_widthA+  <:+> md5A <:+> preview_heightA <:+> preview_urlA <:+> preview_widthA+  <:+> ratingA <:+> sample_file_sizeA <:+> sample_heightA <:+> sample_urlA+  <:+> sample_widthA <:+> scoreA <:+> sourceA <:+> statusA <:+> tagsA+  <:+> widthA+ instance Postable Konachan XML where   postUrl _ _ ts =-    let tags = intercalate "+" ts-    in "https://konachan.com/post/index.xml?tags=" ++ tags-  hardLimit _ = Limit 100+    let tags' = intercalate "+" ts+    in "https://konachan.com/post/index.xml?tags=" ++ tags' ++ "&limit=1000"+  hardLimit _ _ = Limit 100 +instance PostablePaged Konachan XML where+  postUrlPaged s r ts i = postUrl s r ts ++ "&page=" ++ show (i + 1)+ instance Site Konachan where  instance PostParser Konachan XML where   type ImageTy Konachan XML = KonachanPost-  parseResponse _ = map (`betweenPosts` KonachanPost)-                    . runLA (xreadDoc /> G.parsePost) . getResponse+  parseResponse _ = runLA (xreadDoc /> parsePost) . getResponse  instance Counted Konachan XML where   parseCount _ = read . head . runLA (xreadDoc >>> hasName "posts"
src/HBooru/Parsers/Safebooru.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module      :  HBooru.Parsers.Safebooru--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk@@ -15,33 +15,66 @@ -- Module for parsing content from <http://safebooru.org/ safebooru>. module HBooru.Parsers.Safebooru where -import           Data.List-import qualified HBooru.Parsers.GenericBooru as G-import           HBooru.Parsers.GenericBooru.TH (makePost)-import           HBooru.Types-import           Language.Haskell.TH.Syntax (mkName)-import           Text.XML.HXT.Core hiding (mkName)---- | Data type for safebooru posts generated using 'makePost'.-$(makePost (mkName "SafebooruPost"))+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 +-- | Safebooru post record.+type SafebooruPost = R+  '[ "height"+   , "score"+   , "file_url"+   , "parent_id"+   , "sample_url"+   , "sample_width"+   , "sample_height"+   , "preview_url"+   , "rating"+   , "tags"+   , "id"+   , "width"+   , "change"+   , "md5"+   , "creator_id"+   , "has_children"+   , "created_at"+   , "status"+   , "source"+   , "has_notes"+   , "has_comments"+   , "preview_width"+   , "preview_height"+   ]++-- | Parser arrow used for Safebooru.+parsePost ∷ (Functor (cat XmlTree), ArrowXml cat) ⇒ cat XmlTree SafebooruPost+parsePost = hasName "post"+  >>> heightA <:+> scoreA <:+> file_urlA <:+> parent_idA <:+> sample_urlA+  <:+> sample_widthA <:+> sample_heightA <:+> preview_urlA <:+> ratingA+  <:+> tagsA <:+> idA <:+> widthA <:+> changeA <:+> md5A <:+> creator_idA+  <:+> has_childrenA <:+> created_atA <:+> statusA <:+> sourceA <:+> has_notesA+  <:+> has_commentsA <:+> preview_widthA <:+> preview_heightA+ instance Postable Safebooru XML where   postUrl _ _ ts =-    let tags = intercalate "+" ts+    let tags' = intercalate "+" ts     in "http://safebooru.org/index.php?page=dapi&s=post&q=index&limit=100&tags="-       ++ tags ++ "&pid=0"-  hardLimit _ = Limit 100+       ++ tags'+  hardLimit _ _ = Limit 100 +instance PostablePaged Safebooru XML+ instance Site Safebooru where  instance PostParser Safebooru XML where   type ImageTy Safebooru XML = SafebooruPost-  parseResponse _ = map (`betweenPosts` SafebooruPost)-                    . runLA (xreadDoc /> G.parsePost) . getResponse+  parseResponse _ = runLA (xreadDoc /> parsePost) . getResponse  instance Counted Safebooru XML where   parseCount _ = read . head . runLA (xreadDoc >>> hasName "posts"
src/HBooru/Parsers/Yandere.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module      :  HBooru.Parsers.Yandere--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk@@ -16,32 +16,82 @@ -- known in the past as <http://mou.imouto.org MouImouto>. module HBooru.Parsers.Yandere where -import           Data.List-import qualified HBooru.Parsers.GenericBooru as G-import           HBooru.Parsers.GenericBooru.TH (makePost)-import           HBooru.Types-import           Language.Haskell.TH (mkName)-import           Text.XML.HXT.Core hiding (mkName)---- | Data type for Yandere posts generated using 'makePost'.-$(makePost (mkName "YanderePost"))+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 +-- | Alias for a record representing typical Yandere post.+type YanderePost = R+  '[ "actual_preview_height"+   , "actual_preview_width"+   , "author"+   , "change"+   , "created_at"+   , "creator_id"+   , "file_size"+   , "file_url"+   , "frames"+   , "frames_pending"+   , "frames_pending_string"+   , "frames_string"+   , "has_children"+   , "height"+   , "id"+   , "is_held"+   , "is_shown_in_index"+   , "jpeg_file_size"+   , "jpeg_height"+   , "jpeg_url"+   , "jpeg_width"+   , "md5"+   , "preview_height"+   , "preview_url"+   , "preview_width"+   , "rating"+   , "sample_file_size"+   , "sample_height"+   , "sample_url"+   , "sample_width"+   , "score"+   , "source"+   , "status"+   , "tags"+   , "width"+   ]++-- | Parser arrow for XML Yandere posts.+parsePost ∷ (Functor (cat XmlTree), ArrowXml cat) ⇒ cat XmlTree YanderePost+parsePost = hasName "post"+  >>> actual_preview_heightA <:+> actual_preview_widthA <:+> authorA+  <:+> changeA <:+> created_atA <:+> creator_idA <:+> file_sizeA <:+> file_urlA+  <:+> framesA <:+> frames_pendingA <:+> frames_pending_stringA+  <:+> frames_stringA <:+> has_childrenA <:+> heightA <:+> idA <:+> is_heldA+  <:+> is_shown_in_indexA <:+> jpeg_file_sizeA <:+> jpeg_heightA <:+> jpeg_urlA+  <:+> jpeg_widthA <:+> md5A <:+> preview_heightA <:+> preview_urlA+  <:+> preview_widthA <:+> ratingA <:+> sample_file_sizeA <:+> sample_heightA+  <:+> sample_urlA <:+> sample_widthA <:+> scoreA <:+> sourceA <:+> statusA+  <:+> tagsA <:+> widthA+ instance Postable Yandere XML where   postUrl _ _ ts =-    let tags = intercalate "+" ts-    in "https://yande.re/post/index.xml?tags=" ++ tags-  hardLimit _ = Limit 100+    let tgs = intercalate "+" ts+    in "https://yande.re/post/index.xml?tags=" ++ tgs+  hardLimit _ _ = Limit 1000 +instance PostablePaged Yandere XML where+  postUrlPaged s r ts i = postUrl s r ts ++ "&page=" ++ show (i + 1)+ instance Site Yandere where  instance PostParser Yandere XML where   type ImageTy Yandere XML = YanderePost-  parseResponse _ = map (`betweenPosts` YanderePost)-                    . runLA (xreadDoc /> G.parsePost) . getResponse+  parseResponse _ = runLA (xreadDoc /> parsePost) . getResponse  instance Counted Yandere XML where   parseCount _ = read . head . runLA (xreadDoc >>> hasName "posts"
src/HBooru/Types.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | -- Module      :  HBooru.Types--- Copyright   :  (c) Mateusz Kowalczyk 2013+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014 -- License     :  GPL-3 -- -- Maintainer  :  fuuzetsu@fuuzetsu.co.uk@@ -15,7 +18,12 @@ -- Module definining types used by the library. module HBooru.Types where +import Data.Proxy+import GHC.TypeLits (Symbol)+import Data.Vinyl+import Data.Vinyl.TH import Prelude hiding (id)+import Text.XML.HXT.Core hiding (mkName, (<+>))  -- | Tags used for searching in sites. No special escaping is done. -- Note that many sites would treat a tag like \"striped panties\"@@ -63,14 +71,14 @@   toResponse _ = JSONResponse   fromResponse _ = JSON --- | Class specifying a parser that can fetch posts. A post usually consists of--- links to the image, samples, and some meta-data. See--- 'HBooru.Parsers.GenericBooru.GenericPost' for the kind of thing we usually--- get out. The reason for this class is that sometimes we might get different--- information based on the 'DataFormat' we use so we use type families to--- denote this rather than forcing the library user to make do with our best--- guess on what goes into the post. It also allows us to use different post--- types for sites that provide different information.+-- | Class specifying a parser that can fetch posts. A post usually+-- consists of links to the image, samples, and some meta-data. The+-- reason for this class is that sometimes we might get different+-- information based on the 'DataFormat' we use so we use type+-- families to denote this rather than forcing the library user to+-- make do with our best guess on what goes into the post. It also+-- allows us to use different post types for sites that provide+-- different information. class (Site s, DataFormat r) ⇒ PostParser s r where   type ImageTy s r   -- | Given a parser working with 'DataFormat' specified by an instance of@@ -97,11 +105,18 @@ -- allows us to get the information about total number of posts matching our -- query. Some sites don't provide this information. class (Site s, DataFormat r) ⇒ Counted s r where+  -- | Parses out the number of available images from a response.   parseCount ∷ CoerceResponse r r' ⇒ s → r' → Integer +class (Counted s r, Postable s r) ⇒ PostablePaged s r where+  -- | Similar to 'postUrl' but requests images from specific page if+  -- the site allows it.+  postUrlPaged ∷ s → r → [Tag] → Integer → String+  postUrlPaged s r ts i = postUrl s r ts ++ "&pid=" ++ show i+ -- | If we can make an API request to 'Site' in a specific 'DataFormat', we can -- use instances of this class to pass in-class (Site s, DataFormat r) ⇒ Postable s r where+class PostParser s r ⇒ Postable s r where   -- | Given a 'Site', a 'DataFormat' and a list of 'Tag's, an instance of this   -- class should be able to return a 'String' at which we can find data in   -- 'DataFormat' format that honours our tags. This is effectively a URL@@ -111,7 +126,7 @@   -- posts we can fetch from the site at once. The reason for this function here   -- rather than in 'Site' is that we might be parsing data without an API we   -- can post to at all and we're getting our data through other means.-  hardLimit ∷ s → Limit+  hardLimit ∷ s → r → Limit  -- | Describes a site for a parser. The reason why this isn't a simple data type -- is to allow us to write additional parsers in the future without modifying@@ -153,46 +168,166 @@ instance Response JSONResponse where   getResponse (JSONResponse x) = x --- | Class representing a best-case scenario post. We use this--- to convert between different posts for each site while providing--- uniform access. The methods are just the attributes of posts seen--- on Gelbooru-like sites.-class Post a where-  height ∷ a → Integer-  score ∷ a → Integer-  file_url ∷ a → String-  parent_id ∷ a → Maybe Integer-  sample_url ∷ a → String-  sample_width ∷ a → Integer-  sample_height ∷ a → Integer-  preview_url ∷ a → String-  rating ∷ a → Rating-  tags ∷ a → [String]-  id ∷ a → Integer-  width ∷ a → Integer-  change ∷ a → String-  md5 ∷ a → String-  creator_id ∷ a → Integer-  has_children ∷ a → Maybe Bool-  created_at ∷ a → String-  status ∷ a → String-  source ∷ a → String-  has_notes ∷ a → Maybe Bool-  has_comments ∷ a → Maybe Bool-  preview_width ∷ a → Integer-  preview_height ∷ a → Integer-  betweenPosts ∷ Post b ⇒ a → PostConstructor b → b-  betweenPosts g c =-    c (height g) (score g) (file_url g) (parent_id g) (sample_url g)-      (sample_width g) (sample_height g) (preview_url g) (rating g)-      (tags g) (id g) (width g) (change g) (md5 g) (creator_id g)-      (has_children g) (created_at g) (status g) (source g) (has_notes g)-      (has_comments g) (preview_width g) (preview_height g) +instance Functor (LA XmlTree) where+  fmap f (LA g) = LA $ fmap fmap fmap f g --- | A cludge for use with 'betweenPosts'-type PostConstructor b =-  Integer -> Integer -> String -> Maybe Integer -> String -> Integer -> Integer-  -> String -> Rating -> [String] -> Integer -> Integer -> String -> String-  -> Integer -> Maybe Bool -> String -> String -> String -> Maybe Bool-  -> Maybe Bool -> Integer -> Integer -> b+makeUniverse' ''Symbol "ElF"+semantics ''ElF [ [t| "height" |]                :~> [t| Integer |]+                , [t| "score" |]                 :~> [t| Integer |]+                , [t| "file_url" |]              :~> [t| String |]+                , [t| "parent_id" |]             :~> [t| Maybe Integer |]+                , [t| "sample_url" |]            :~> [t| String |]+                , [t| "sample_width" |]          :~> [t| Integer |]+                , [t| "sample_height" |]         :~> [t| Integer |]+                , [t| "preview_url" |]           :~> [t| String |]+                , [t| "rating" |]                :~> [t| Rating |]+                , [t| "tags" |]                  :~> [t| [Tag] |]+                , [t| "id" |]                    :~> [t| Integer |]+                , [t| "width" |]                 :~> [t| String |]+                , [t| "change" |]                :~> [t| String |]+                , [t| "md5" |]                   :~> [t| String |]+                , [t| "creator_id" |]            :~> [t| Integer |]+                , [t| "has_children" |]          :~> [t| Bool |]+                , [t| "created_at" |]            :~> [t| String |]+                , [t| "status" |]                :~> [t| String |]+                , [t| "source" |]                :~> [t| String |]+                , [t| "has_notes" |]             :~> [t| Maybe Bool |]+                , [t| "has_comments" |]          :~> [t| Maybe Bool |]+                , [t| "preview_width" |]         :~> [t| Integer |]+                , [t| "preview_height" |]        :~> [t| Integer |]+                , [t| "author" |]                :~> [t| String |]+                , [t| "frames" |]                :~> [t| String |]+                , [t| "frames_pending" |]        :~> [t| String |]+                , [t| "frames_pending_string" |] :~> [t| String |]+                , [t| "frames_string" |]         :~> [t| String |]+                , [t| "is_held" |]               :~> [t| Bool |]+                , [t| "is_shown_in_index" |]     :~> [t| Bool |]+                , [t| "jpeg_file_size" |]        :~> [t| Integer |]+                , [t| "jpeg_height" |]           :~> [t| Integer |]+                , [t| "jpeg_url" |]              :~> [t| String |]+                , [t| "jpeg_width" |]            :~> [t| Integer |]+                , [t| "sample_file_size" |]      :~> [t| Integer |]+                , [t| "actual_preview_height" |] :~> [t| Integer |]+                , [t| "actual_preview_width" |]  :~> [t| Integer |]+                , [t| "file_size" |]             :~> [t| Integer |]+                ]++-- | Handy synonym hiding 'ElF'.+type R a = PlainRec ElF a++-- * Commonly used fields++height ∷ Proxy "height"+height = Proxy++score ∷ Proxy "score"+score = Proxy++file_url ∷ Proxy "file_url"+file_url = Proxy++parent_id ∷ Proxy "parent_id"+parent_id = Proxy++sample_url ∷ Proxy "sample_url"+sample_url = Proxy++sample_width ∷ Proxy "sample_width"+sample_width = Proxy++sample_height ∷ Proxy "sample_height"+sample_height = Proxy++preview_url ∷ Proxy "preview_url"+preview_url = Proxy++rating ∷ Proxy "rating"+rating = Proxy++tags ∷ Proxy "tags"+tags = Proxy++id ∷ Proxy "id"+id = Proxy++width ∷ Proxy "width"+width = Proxy++change ∷ Proxy "change"+change = Proxy++md5 ∷ Proxy "md5"+md5 = Proxy++creator_id ∷ Proxy "creator_id"+creator_id = Proxy++has_children ∷ Proxy "has_children"+has_children = Proxy++created_at ∷ Proxy "created_at"+created_at = Proxy++status ∷ Proxy "status"+status = Proxy++source ∷ Proxy "source"+source = Proxy++has_notes ∷ Proxy "has_notes"+has_notes = Proxy++has_comments ∷ Proxy "has_comments"+has_comments = Proxy++preview_width ∷ Proxy "preview_width"+preview_width = Proxy++preview_height ∷ Proxy "preview_height"+preview_height = Proxy++author ∷ Proxy "author"+author = Proxy++frames ∷ Proxy "frames"+frames = Proxy++frames_pending ∷ Proxy "frames_pending"+frames_pending = Proxy++frames_pending_string ∷ Proxy "frames_pending_string"+frames_pending_string = Proxy++frames_string ∷ Proxy "frames_string"+frames_string = Proxy++is_held ∷ Proxy "is_held"+is_held = Proxy++is_shown_in_index ∷ Proxy "is_shown_in_index"+is_shown_in_index = Proxy++jpeg_file_size ∷ Proxy "jpeg_file_size"+jpeg_file_size = Proxy++jpeg_height ∷ Proxy "jpeg_height"+jpeg_height = Proxy++jpeg_url ∷ Proxy "jpeg_url"+jpeg_url = Proxy++jpeg_width ∷ Proxy "jpeg_width"+jpeg_width = Proxy++sample_file_size ∷ Proxy "sample_file_size"+sample_file_size = Proxy++actual_preview_height ∷ Proxy "actual_preview_height"+actual_preview_height = Proxy++actual_preview_width ∷ Proxy "actual_preview_width"+actual_preview_width = Proxy++file_size ∷ Proxy "file_size"+file_size = Proxy
+ src/Main.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE LambdaCase #-}+module Main where++import Control.Applicative ((<$>))+import Data.Vinyl+import HBooru.Network+import HBooru.Parsers.Gelbooru+import HBooru.Parsers.Ichijou+import HBooru.Parsers.Konachan+import HBooru.Parsers.Safebooru+import HBooru.Parsers.Yandere+import HBooru.Types+import System.Environment (getArgs)++main ∷ IO ()+main = getArgs >>= \case+  [] → putStrLn help+  xs → fetchImageLinks xs >>= mapM_ putStrLn++fetchImageLinks ∷ [Tag] → IO [String]+fetchImageLinks xs = do+  let f p = map (file_url `rGet`) <$> fetchAllTaggedPosts p XML xs+  g ← f Gelbooru+  i ← f Ichijou+  k ← f Konachan+  s ← f Safebooru+  y ← f Yandere+  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"+       ]