robots-txt 0.4.0.0 → 0.4.1.0
raw patch · 2 files changed
+151/−27 lines, 2 filesdep +old-localedep +timedep ~attoparsec
Dependencies added: old-locale, time
Dependency ranges changed: attoparsec
Files
- robots-txt.cabal +4/−2
- src/Network/HTTP/Robots.hs +147/−25
robots-txt.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: robots-txt-version: 0.4.0.0+version: 0.4.1.0 synopsis: Parser for robots.txt description: This is an attoparsec parser for robots.txt files homepage: http://github.com/meanpath/robots@@ -26,7 +26,9 @@ hs-source-dirs: src build-depends: base >= 4 && <= 5 , bytestring- , attoparsec+ , attoparsec >= 0.12.1 && < 0.13+ , time >= 1.4 && < 1.5+ , old-locale >= 1.0.0.5 && < 1.1 test-suite tests type: exitcode-stdio-1.0
src/Network/HTTP/Robots.hs view
@@ -2,12 +2,18 @@ module Network.HTTP.Robots where import Control.Applicative-import Data.Attoparsec.Char8 hiding (skipSpace)+import Control.Monad+import Data.Attoparsec.ByteString.Char8 hiding (skipSpace) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS+import qualified Data.Attoparsec.Text as AT (isEndOfLine) import Data.Either (partitionEithers) import Data.List (find) import Data.Maybe (catMaybes)+import Data.Char (toUpper)+import Data.Time.Clock+import Data.Time.LocalTime()+import Data.Ratio type Robot = ([([UserAgent], [Directive])], [Unparsable]) @@ -17,12 +23,107 @@ deriving (Show,Eq) type Path = ByteString +-- http://www.conman.org/people/spc/robots2.html+-- This was never actually accepted as a standard,+-- but some sites do use it.+type TimeInterval = (DiffTime, DiffTime)++-- Crawldelay may have a decimal point+-- http://help.yandex.com/webmaster/controlling-robot/robots-txt.xml+-- Added directives NoArchive, NoSnippet, NoTranslate, SiteMap.+-- http://bloganddiscussion.com/anythingcomputer/1/robots-txt-noarchive-nocache-nosnippet/ data Directive = Allow Path | Disallow Path- | CrawlDelay Int+ | CrawlDelay { crawlDelay :: Rational+ , timeInterval :: TimeInterval+ }+ | NoArchive Path+ | NoSnippet Path+ | NoTranslate Path+ -- not used by Google, Yahoo or Live Search/Bing+ -- http://searchengineland.com/a-deeper-look-at-robotstxt-17573+ | NoIndex Path deriving (Show,Eq) +-- For use in the attoparsec monad, allows to reparse a sub expression+subParser :: Parser a -> ByteString -> Parser a+subParser p = either (const mzero) return . parseOnly p+++-- Seems the rational parser is unsecure in the presence of an exponent+-- but since there is no alternative to parse a rational, we just to refuse+-- to parse numbers with 'e' / exponent+-- https://hackage.haskell.org/package/attoparsec-0.12.1.0/docs/Data-Attoparsec-ByteString-Char8.html#v:rational+safeParseRational :: Parser Rational+safeParseRational = do+ (bs,_) <- match scientific+ if BS.elem 'e' bs || BS.elem 'E' bs+ then mzero+ else subParser rational bs++-- Yeah, robots.txt should be ASCII, but some sites+-- include the UTF-8 marker at start.+-- We just drop it, but handle the file as ASCII.+dropUTF8BOM :: ByteString -> ByteString+dropUTF8BOM bs = if BS.take 3 bs == ( '\239' `BS.cons`+ '\187' `BS.cons`+ '\191' `BS.cons` BS.empty)+ then BS.drop 3 bs+ else bs++parseHourMinute :: Parser (Integer,Integer)+parseHourMinute = parseWithColon <|> parseWithoutColon+ where+ parseWithColon = do+ hours <- skipSpace >> decimal+ void $ skipSpace >> char ':'+ mins <- skipSpace >> decimal+ return (hours,mins)+ parseWithoutColon = do+ h <- Data.Attoparsec.ByteString.Char8.take 2 >>= subParser decimal+ m <- Data.Attoparsec.ByteString.Char8.take 2 >>= subParser decimal+ return (h,m)++parseTimeInterval :: Parser TimeInterval+parseTimeInterval = do+ (hours_start, mins_start) <- parseHourMinute+ void $ (skipSpace >> char '-' >> skipSpace) <|> skipSpace+ (hours_end , mins_end ) <- parseHourMinute+ return ( secondsToDiffTime (hours_start * 60 * 60 + mins_start * 60)+ , secondsToDiffTime (hours_end * 60 * 60 + mins_end * 60))++allDay :: TimeInterval+allDay = ( secondsToDiffTime 0+ , secondsToDiffTime (24*60*60) -- because of leap seconds+ )++parseRequestRate :: Parser Directive+parseRequestRate = do+ void $ stringCI "Request-rate:"+ docs <- skipSpace >> decimal+ void $ skipSpace >> char '/'+ ptim <- skipSpace >> decimal+ units<- skipSpace >> ( (char 's' >> return ( 1 :: Integer))+ <|> (char 'm' >> return ( 60 :: Integer))+ <|> (char 'h' >> return (60*60 :: Integer))+ <|> return ( 1 :: Integer)+ )+ tint <- skipSpace >> ( parseTimeInterval <|> return allDay)+ return $ CrawlDelay ((ptim * units) % docs) tint++parseVisitTime :: Parser Directive+parseVisitTime = do+ void $ stringCI "Visit-time:"+ tint <- skipSpace >> parseTimeInterval+ return $ CrawlDelay ( 0 % 1) tint++parseCrawlDelay :: Parser Directive+parseCrawlDelay = do+ delay <- stringCI "Crawl-Delay:" >> skipSpace >> safeParseRational+ return $ CrawlDelay delay allDay+ -- ... yeah.+strip :: ByteString -> ByteString strip = BS.reverse . BS.dropWhile (==' ') . BS.reverse . BS.dropWhile (==' ') -- | parseRobots is the main entry point for parsing a robots.txt file.@@ -30,7 +131,7 @@ parseRobots input = case parsed of -- special case no parsable lines and rubbish Right ([], out@(_:_)) ->- Left ("no parsable lines: " ++ (show out))+ Left ("no parsable lines: " ++ show out) _ -> parsed where parsed = parseOnly robotP@@ -38,22 +139,26 @@ -- Filthy hack to account for the fact we don't grab sitemaps -- properly. people seem to just whack them anywhere, which makes it -- hard to write a nice parser for them.- . filter (not . ( "Sitemap:" `BS.isPrefixOf`))+ . filter (not . BS.isPrefixOf "SITEMAP:" . BS.map toUpper)+ . filter (not . BS.isPrefixOf "HOST:" . BS.map toUpper) . filter (\x -> BS.head x /= '#' ) . filter (not . BS.null) . map strip . BS.lines- -- worst way of handling window newlines ever+ -- worst way of handling windows newlines ever . BS.filter (/= '\r')+ . dropUTF8BOM $ input robotP :: Parser Robot robotP = do- (dirs, unparsable) <- partitionEithers <$> many (eitherP agentDirectiveP unparsableP) <?> "robot"+ (dirs, unparsable) <- partitionEithers <$> many (eitherP agentDirectiveP unparsableP) <?> "robot" return (dirs, filter (/= "") unparsable) -unparsableP = takeTill (=='\n') <* endOfLine -- char '\n'+unparsableP :: Parser ByteString+unparsableP = takeTill AT.isEndOfLine <* endOfLine -- char '\n' +agentDirectiveP :: Parser ([UserAgent],[Directive]) agentDirectiveP = (,) <$> many1 agentP <*> many1 directiveP <?> "agentDirective" @@ -61,43 +166,60 @@ skipSpace = skipWhile (\x -> x==' ' || x == '\t') directiveP :: Parser Directive-directiveP = choice [ Allow <$> (stringCI "Allow:" >> skipSpace >> tokenP)- , (stringCI "Disallow:" >> skipSpace >>- (choice [Disallow <$> tokenP,- -- this requires some explanation.- -- The RFC suggests that an empty- -- Disallow line means anything is- -- allowed. Being semantically- -- equivalent to 'Allow: "/"',- -- I have chosen to change it here- -- rather than carry the bogus- -- distinction around.- endOfLine >> return (Allow "/") ] ))- , CrawlDelay <$> (stringCI "Crawl-delay:" >> skipSpace >>decimal)+directiveP = choice [ stringCI "Disallow:" >> skipSpace >>+ ((Disallow <$> tokenP) <|>+ -- This requires some explanation.+ -- The RFC suggests that an empty Disallow line means+ -- anything is allowed. Being semantically equivalent to+ -- 'Allow: "/"', I have chosen to change it here+ -- rather than carry the bogus distinction around.+ (endOfLine >> return (Allow "/")))+ , stringCI "Allow:" >> skipSpace >>+ ((Allow <$> tokenP) <|>+ -- If an empty disallow means 'disallow nothing',+ -- an empty allow means 'allow nothing'. Right?+ -- Not sure, actually, but only the americanexpress.com+ -- has such a case, which in one hand I am tempted+ -- to consider an error... but for now:+ (endOfLine >> return (Disallow "/")))+ , parseCrawlDelay+ , parseRequestRate+ , parseVisitTime+ , NoArchive <$> (stringCI "Noarchive:" >> skipSpace >> tokenP)+ , NoSnippet <$> (stringCI "Nosnippet:" >> skipSpace >> tokenP)+ , NoTranslate <$> (stringCI "Notranslate:">> skipSpace >> tokenP)+ , NoIndex <$> (stringCI "Noindex:" >> skipSpace >> tokenP) ] <* commentsP <?> "directive" agentP :: Parser UserAgent agentP = do- stringCI "user-agent:"+ void $ stringCI "user-agent:" skipSpace ((string "*" >> return Wildcard) <|>- (Literal <$> tokenP)) <* skipSpace <* endOfLine <?> "agent"+ (Literal <$> tokenWithSpacesP)) <* skipSpace <* endOfLine <?> "agent" commentsP :: Parser () commentsP = skipSpace >>- ((string "#" >> takeTill (=='\n') >> skipSpace >> endOfLine) <|> return ())+ ( (string "#" >> takeTill AT.isEndOfLine >> endOfLine)+ <|> endOfLine+ <|> return ()) + tokenP :: Parser ByteString tokenP = skipSpace >> takeWhile1 (not . isSpace) <* skipSpace+tokenWithSpacesP :: Parser ByteString+tokenWithSpacesP = skipSpace >> takeWhile1 (not . (\c -> c == '#' || AT.isEndOfLine c))+ <* takeTill AT.isEndOfLine -- I lack the art to make this prettier.+-- Currently does not take into account the CrawlDelay / Request Rate directives canAccess :: ByteString -> Robot -> Path -> Bool canAccess _ _ "/robots.txt" = True -- special-cased canAccess agent (robot,_) path = case stanzas of [] -> True ((_,directives):_) -> matchingDirective directives- where stanzas = catMaybes [find ((any (`isLiteralSubstring` agent)) . fst) robot,+ where stanzas = catMaybes [find (any (`isLiteralSubstring` agent) . fst) robot, find ((Wildcard `elem`) . fst) robot] @@ -108,6 +230,6 @@ Allow robot_path -> robot_path `BS.isPrefixOf` path || matchingDirective xs Disallow robot_path ->- (not $ robot_path `BS.isPrefixOf` path) && matchingDirective xs+ not (robot_path `BS.isPrefixOf` path) && matchingDirective xs _ -> matchingDirective xs