{-# Language OverloadedStrings #-}
-- todo [release] date?
-- todo [release] fallo diventare script, asptta che cabal 2.4 va in
-- deb stable.
module Main where
import Control.Applicative
import System.Environment
import Network.HTTP.Simple
import Text.HTML.Scalpel.Core
import Text.RSS.Syntax
import Text.RSS.Export
import qualified Data.List as L
import qualified Data.String as DS
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLI
import qualified Data.Text.Encoding as TE
import qualified Data.XML.Types as XT
import qualified Text.Atom.Feed as AF
import qualified Text.URI as U
main :: IO ()
main = -- get args
map T.pack <$> getArgs >>= \as ->
-- malformed input
if null as ||
length as > 1 ||
head as `elem` ["--help", "-h"]
then putStrLn helps
else
-- scrape
let url = head as in
scrapeGet url (page url) >>= \p ->
printRSS url p
where
scrapeGet :: URL -> Scraper T.Text a -> IO a
scrapeGet url s = getURLBody url >>= \b ->
let r = maybe (error errs)
id
(scrapeStringLike b s)
in return r
-----------
-- TYPES --
-----------
type Title = T.Text
type URL = T.Text
data Page = Page Title URL [Article]
deriving (Show, Eq)
-- URL: url of the feed/page
type Author = T.Text
type Description = T.Text
data Article = Article Title URL Author Description
deriving (Show, Eq)
------------
-- SCRAPE --
------------
page :: URL -> Scraper T.Text Page
page u = Page <$> text "title"
<*> pure u
<*> chroot ("div" @: ["id" @= "gs_res_ccl_mid"]) entries
entries :: Scraper T.Text [Article]
entries = chroots ("div" @: [hasClass "gs_ri"]) paper
where
paper = Article <$> text ("h3" @: [hasClass "gs_rt"])
<*> (cleanGBooks <$> attr "href" "a")
<*> text ("div" @: [hasClass "gs_a"])
<*> description
description :: Scraper T.Text Description
description = text ("div" @: [hasClass "gs_rs"]) <|>
pure "No description available."
-- todo rimuovi span?
-- todo aggiungi test
-- Title: channel title
buildRSS :: Title -> Page -> RSS
buildRSS pt (Page t u as) =
(nullRSS "ERRORE-T" "ERRORE-L") {
rssAttrs = [dublinNamespace],
rssChannel = (nullChannel pt u) {rssItems = map buildItem as} }
where
buildItem :: Article -> RSSItem
buildItem (Article t u a d) =
(nullItem t) {
rssItemLink = Just $ u,
-- rssItemAuthor = Just $ a,
rssItemOther = [dcCreator a],
rssItemDescription = Just d }
-- http://www.rssboard.org/rss-profile#namespace-elements-dublin-creator
dcCreator :: Author -> XT.Element
dcCreator a = XT.Element "dc:creator" []
[XT.NodeContent $ XT.ContentText a]
-- needed for dcCreator
dublinNamespace :: AF.Attr
dublinNamespace =
("xmlns:dc",
[XT.ContentText "http://purl.org/dc/elements/1.1/"])
-------------
-- GET/PUT --
-------------
getURLBody :: URL -> IO T.Text
getURLBody url = getResponseBody <$> httpBS req >>= \b ->
return (TE.decodeLatin1 b)
where
req = DS.fromString (T.unpack url)
feedTitle :: URL -> Title
feedTitle url = case lookup "q" (U.queryToPairs $ T.unpack url) of
Nothing -> "Error: title not found"
Just t -> "gscholar-rss: " <> T.pack t
-- removes 'ots' and 'sig' from a google books url
cleanGBooks :: URL -> URL
cleanGBooks url
| condA =
let
qry = U.uriQueryItems uri
fqr = filter filtFun qry
u' = uri { U.uriQuery = Just (U.pairsToQuery fqr)}
in
T.pack . show $ u'
| otherwise = url
where
uri = maybe (error "gclean: misparse")
id
(U.parseURI $ T.unpack url)
condA = case U.uriRegName uri of
Nothing -> False -- citation, no uri
Just rn -> L.isPrefixOf "books.google" rn
filtFun :: (String, String) -> Bool
filtFun (l, _) = not (elem l ["ots", "sig"])
printRSS :: URL -> Page -> IO ()
printRSS url s =
case textRSS . buildRSS (feedTitle url) $ s of
Nothing -> error errs
Just s -> TLI.putStrLn s
helps :: String
helps = unlines
["invoke as: gscholar-rss <search-url>",
"manual and examples: http://ariis.it/static/articles/gscholar-rss/page.html",
"v 0.2.5.0, released under the GPLv3"]
errs :: String
errs = "Could not parse, please report to fa-ml@ariis.it"