"
+ email = if isHasEmail
+ then Just $ fromAttrib "href" tag
+ else Nothing
+ authorTag = if isHasEmail
+ then last $ take 3 rest
+ else tag
+ author = if isTagText authorTag
+ then Just $ fromTagText authorTag
+ else Nothing
+ in (author, email, rest)
+ in (f author email, newRest)
+ -----------------------------------------------
+ parseTrip f tags =
+ let rest = dropWhile (~/= sTripTag s) tags
+ (trip, newRest) =
+ if null rest
+ then (Nothing, tags)
+ else let tag = head $ tail rest
+ in if isTagText tag
+ then (Just $ fromTagText tag, rest)
+ else (Nothing, rest)
+ in (f trip, newRest)
+ -----------------------------------------------
+ -- required
+ parseTime f tags =
+ let (t, rest) = break (~== sTimeCloseTag s) tags
+ time = fromTagText $ last t
+ in (f time, rest)
+ -----------------------------------------------
+ parseImg f t =
+ let r = dropWhile (~/= sPropertiesTag s) t
+ rest = if null r
+ then dropWhile (~/= sPropertiesTag s) tags
+ else r
+ (img, newRest) =
+ if null rest
+ then (Nothing, t)
+ else let (properties, rest') =
+ break (~== sPropertiesCloseTag s) rest
+ imgU = fromAttrib "href" $ head $
+ dropWhile (~/= sImgTag s) rest'
+ thumbU = fromAttrib "src" $ head $
+ dropWhile (~/= sThumbTag s) rest'
+ in (Just $ Img { imgProperties = innerText $ properties
+ , imgURL = imgU
+ , thumbURL = thumbU
+ }, rest')
+ in (f img, newRest)
+ -----------------------------------------------
+ -- required
+ parseBody f tags =
+ let bodyTags =
+ if sBodyWalkAll s
+ then reverse $ dropWhile (~/= sBodyCloseTag s) $
+ reverse $ dropWhile (~/= sBodyTag s) tags
+ else takeWhile (~/= sBodyCloseTag s) $
+ dropWhile (~/= sBodyTag s) tags
+ body = innerText $ map parseWakabaMark bodyTags
+ in (f body, [])
+ where
+ -- FIXME: parse it correctly!!!
+ parseWakabaMark tag | tag ~== "
" = TagText "\n"
+ parseWakabaMark tag | tag ~== "" = TagText "\n"
+ parseWakabaMark tag | tag ~== "
" = TagText "\n"
+ parseWakabaMark tag = tag
+
+
+-- | Show post.
+showPost :: Chan -> (Integer, Post) -> String
+showPost chan (n, p) =
+ let title = maybe "" id $ postTitle p
+ author = maybe "" id $ postAuthor p
+ email = maybe "" id $ postEmail p
+ trip = maybe "" id $ postTrip p
+ time = postTime p
+ number = show n
+ (properties, imgU, thumbU) =
+ maybe ("", "", "")
+ (\i -> (imgProperties i
+ ,fixURL (imgURL i)
+ ,fixURL (thumbURL i))) $ postImg p
+ body = postBody p
+
+ -- formating
+ format = "_<author>_<trip>_<email>_<time>_#<number>|\
+ \<img>|\
+ \<body>"
+ formating = [ ("<body>", body)
+ , ("<title>", title)
+ , ("<author>", author)
+ , ("<email>", email)
+ , ("<trip>", trip)
+ , ("<time>", time)
+ , ("<number>", number)
+ , ("<size>", properties)
+ , ("<img>", imgU)
+ , ("<thumb>", thumbU)
+ , ("|", "\n")
+ , ("_", " ")
+ ]
+ in foldr (\(f, r) s -> replace f r s) format formating
+ where
+ fixURL u = if "http://" `isPrefixOf` u
+ then u
+ else (curl chan)++u
diff --git a/Parsers/Thread.hs b/Parsers/Thread.hs
new file mode 100644
--- /dev/null
+++ b/Parsers/Thread.hs
@@ -0,0 +1,71 @@
+-- | Parsers/Thread.hs
+-- A module which contain functions for split thread on ports and
+-- parse it all together.
+
+module Parsers.Thread (
+ ThreadSettings(..),
+ parseThread,
+ parsePosts
+) where
+
+import Parsers.Post
+
+import Data.Maybe
+import Text.Regex.Posix
+import Text.HTML.TagSoup
+import Codec.Binary.UTF8.String
+import Data.List.Utils
+
+
+-- | Settings for post parser.
+data ThreadSettings = ThreadSettings
+ { sThreadSplitter :: String
+ , sAfterSplit :: Bool
+ }
+
+-- | Post with number.
+type NPost = (Integer, Post)
+
+
+-- | Parse thread on main page.
+parseThread :: ThreadSettings -> PostSettings -> Integer -> String -> [NPost]
+parseThread tSets pSets lastPost body =
+ let threads = split (sThreadSplitter tSets) body
+
+ p [] = []
+ p [number] | lastPost < number = [number]
+ p _ = []
+
+ in if length threads < 2
+ then []
+ else let thread = if sAfterSplit tSets
+ then head $ tail threads
+ else head threads
+ in universalParser p pSets thread
+
+
+-- | Parse full thread.
+parsePosts :: PostSettings -> Integer -> String -> [NPost]
+parsePosts pSets lastPost body =
+ let p [] = []
+ p numbers | lastPost == 0 = [last numbers]
+ p numbers = reverse $ take 10 $ reverse $
+ dropWhile (<=lastPost) numbers
+
+ in universalParser p pSets body
+
+
+-- | Universal parser.
+universalParser :: ([Integer] -> [Integer]) -> PostSettings -> String -> [NPost]
+universalParser p pSets body =
+ let chunks = split (sPostSplitter pSets) body
+ nposts' = map (\chunk -> (parseNumber chunk, chunk)) chunks
+ needed = p $ map fst nposts'
+
+ parseNumber = read . filter (`elem` ['0'..'9']) .
+ flip (=~) (sPostNumberTag pSets)
+ parseNPost (number, chunk) =
+ if number `elem` needed
+ then Just (number, parsePost pSets $ parseTags $ decodeString chunk)
+ else Nothing
+ in catMaybes $ map parseNPost nposts'
diff --git a/Parsers/Wakaba.hs b/Parsers/Wakaba.hs
new file mode 100644
--- /dev/null
+++ b/Parsers/Wakaba.hs
@@ -0,0 +1,39 @@
+-- | Parsers/Wakaba.hs
+-- Wakaba parsers.
+
+module Parsers.Wakaba (
+ wakabaPostSettings,
+ wakabaThread,
+ wakabaBoard
+) where
+
+import Parsers.Thread
+import Parsers.Post
+
+
+wakabaPostSettings = PostSettings
+ { sPostSplitter = "<td class=\"reply\""
+ , sPostNumberTag = "<a name=\"[^\"s]+\""
+ , sTitleTag = ("<span class=replytitle>",
+ "<span class=filetitle>")
+ , sAuthorTag = ("<span class=commentpostername>",
+ "<span class=postername>")
+ , sTripTag = "<span class=postertrip>"
+ , sTimeCloseTag = "</label>"
+ , sPropertiesTag = "<span class=filesize>"
+ , sPropertiesCloseTag = "</span>"
+ , sImgTag = "<a target=_blank>"
+ , sThumbTag = "<img class=thumb>"
+ , sBodyWalkAll = True
+ , sBodyTag = "<blockquote>"
+ , sBodyCloseTag = "</blockquote>"
+ }
+
+wakabaThreadSettings = ThreadSettings
+ { sThreadSplitter = "<br clear=\"left\" /><hr />"
+ , sAfterSplit = False
+ }
+
+
+wakabaThread = parsePosts wakabaPostSettings
+wakabaBoard = parseThread wakabaThreadSettings wakabaPostSettings
diff --git a/mahoro.cabal b/mahoro.cabal
--- a/mahoro.cabal
+++ b/mahoro.cabal
@@ -1,9 +1,10 @@
Name: mahoro
-Version: 0.1.1
-Synopsis: chans to XMPP gate
+Version: 0.1.2
+Synopsis: ImageBoards to XMPP gate
Category: Web
Description: Chans (ImageBoards) to XMPP gate. Supports Wakaba,
- Kusaba and other engines.
+ Kusaba and other engines. Settings stored
+ in ~/.mahororc file.
License: GPL
License-file: LICENSE
Author: Kagami <newanon@yandex.ru>
@@ -13,9 +14,12 @@
Cabal-Version: >=1.2
Data-Files: INSTALL, mahororc.example
-Extra-Source-Files: debug.sh, install.sh, Threads.hs
- Config.hs, DB.hs, DBState.hs, HTTP.hs
- Help.hs, Main.hs, Parsers.hs, Setup.hs
+Extra-Source-Files: debug.sh, install.sh, Threads.hs,
+ Config.hs, DB.hs, DBState.hs, HTTP.hs,
+ Help.hs, Parsers.hs, Setup.hs,
+ Parsers/Dobrochan.hs, Parsers/Nowai.hs,
+ Parsers/Post.hs, Parsers/Thread.hs,
+ Parsers/Wakaba.hs
Executable mahoro
Main-is: Main.hs