mahoro 0.1.1 → 0.1.2
raw patch · 7 files changed
+377/−7 lines, 7 files
Files
- HTTP.hs +1/−1
- Parsers/Dobrochan.hs +29/−0
- Parsers/Nowai.hs +32/−0
- Parsers/Post.hs +195/−0
- Parsers/Thread.hs +71/−0
- Parsers/Wakaba.hs +39/−0
- mahoro.cabal +10/−6
HTTP.hs view
@@ -30,7 +30,7 @@ curlOptions :: Chan -> [CurlOption] curlOptions chan =- [ CurlTimeout 5+ [ CurlTimeout 7 , CurlReferer (curl chan) , CurlUserAgent "Mozilla/5.0 (X11; U; Linux i686; en-US;\ \rv:1.9.1.2) Gecko/20090804 Shiretoko/3.5.2"
+ Parsers/Dobrochan.hs view
@@ -0,0 +1,29 @@+-- | Parsers/Dobrochan.hs+-- Dobrochan parsers.++module Parsers.Dobrochan (+ dobrochanThread,+ dobrochanBoard+) where++import Parsers.Post+import Parsers.Thread+import Parsers.Wakaba+++dobrochanPostSettings = wakabaPostSettings+ { sPropertiesTag = "<div class=fileinfo>"+ , sPropertiesCloseTag = "</div>"+ , sBodyWalkAll = False+ , sBodyTag = "<div class=message>"+ , sBodyCloseTag = "</div>"+ }++dobrochanThreadSettings = ThreadSettings+ { sThreadSplitter = "<div class=\"thread"+ , sAfterSplit = True+ }+++dobrochanThread = parsePosts dobrochanPostSettings+dobrochanBoard = parseThread dobrochanThreadSettings dobrochanPostSettings
+ Parsers/Nowai.hs view
@@ -0,0 +1,32 @@+-- | Parsers/Nowai.hs+-- Nowai parsers.++module Parsers.Nowai (+ nowaiThread,+ nowaiBoard+) where++import Parsers.Post+import Parsers.Thread+import Parsers.Wakaba+++nowaiPostSettings = wakabaPostSettings+ { sPostSplitter = "<table class=\"post\""+ , sPostNumberTag = "del/[0-9]+\\.html"+ , sTitleTag = ("<span class=caption>",+ "<span class=caption>")+ , sTimeCloseTag = "<a class=postid>"+ , sPropertiesTag = "<span class=fileinfo>"+ , sBodyTag = "<span class=posttext>"+ , sBodyCloseTag = "</span>"+ }++nowaiThreadSettings = ThreadSettings+ { sThreadSplitter = "<table class=\"thread"+ , sAfterSplit = True+ }+++nowaiThread = parsePosts nowaiPostSettings+nowaiBoard = parseThread nowaiThreadSettings nowaiPostSettings
+ Parsers/Post.hs view
@@ -0,0 +1,195 @@+-- | Parsers/Post.hs+-- A module which contain functions for parse and show thread post.++module Parsers.Post (+ Post(..),+ PostSettings(..),+ parsePost,+ showPost+) where++import Config++import Text.HTML.TagSoup+import Data.List.Utils++import Data.List+++-- | Post structure.+data Post = Post+ { postTitle :: Maybe String+ , postAuthor :: Maybe String+ , postEmail :: Maybe String+ , postTrip :: Maybe String+ , postTime :: String+ , postImg :: Maybe Img+ , postBody :: String+ } deriving Show++-- | Img structure.+data Img = Img+ { imgProperties :: String+ , imgURL :: String+ , thumbURL :: String+ } deriving Show++-- | Settings for post parser.+data PostSettings = PostSettings+ { sPostSplitter :: String+ , sPostNumberTag :: String+ , sTitleTag :: (String, String)+ , sAuthorTag :: (String, String)+ , sTripTag :: String+ , sTimeCloseTag :: String+ , sPropertiesTag :: String+ , sPropertiesCloseTag :: String+ , sImgTag :: String+ , sThumbTag :: String+ , sBodyWalkAll :: Bool+ , sBodyTag :: String+ , sBodyCloseTag :: String+ }+++-- | Parse entire post.+parsePost :: PostSettings -> [Tag] -> Post+parsePost s tags = fst $+ parseTitle Post tags >==+ parseAuthorAndEmail >==+ parseTrip >==+ parseTime >==+ parseImg >==+ parseBody+ where+ (f, rest) >== f2 = f2 f rest+ -----------------------------------------------+ parseTitle f tags =+ let r = dropWhile (~/= (fst $ sTitleTag s)) tags+ rest = if null r+ then dropWhile (~/= (snd $ sTitleTag s)) tags+ else r+ (title, newRest) =+ if null rest+ then (Nothing, tags)+ else let tag = head $ tail rest+ in if isTagText tag+ then (Just $ fromTagText tag, rest)+ else (Nothing, tags)+ in (f title, newRest)+ -----------------------------------------------+ parseAuthorAndEmail f tags =+ let r = dropWhile (~/= (fst $ sAuthorTag s)) tags+ rest = if null r+ then dropWhile (~/= (snd $ sAuthorTag s)) tags+ else r+ (author, email, newRest) =+ if null rest+ then (Nothing, Nothing, tags)+ else let tag = head $ tail rest+ isHasEmail = tag ~== "<a href>"+ 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 ~== "<br>" = TagText "\n"+ parseWakabaMark tag | tag ~== "<p>" = TagText "\n"+ parseWakabaMark tag | tag ~== "</p>" = 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 = "<title>_<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
+ Parsers/Thread.hs view
@@ -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'
+ Parsers/Wakaba.hs view
@@ -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
mahoro.cabal view
@@ -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