diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/robots-txt.cabal b/robots-txt.cabal --- a/robots-txt.cabal +++ b/robots-txt.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: robots-txt -version: 0.4.1.8 +version: 0.4.1.9 synopsis: Parser for robots.txt description: This is an attoparsec parser for robots.txt files homepage: http://github.com/mwotton/robots @@ -18,16 +18,16 @@ source-repository head type: git - location: git://github.com/mwotton/robots.git + location: https://github.com/mwotton/robots.git library exposed-modules: Network.HTTP.Robots -- other-modules: hs-source-dirs: src - build-depends: base >= 4 && <= 5 - , bytestring + build-depends: base >= 4 && < 5 + , bytestring < 0.13 , attoparsec >= 0.12.1.6 && < 0.15 - , time >= 1.4 + , time >= 1.4 && < 1.13 , old-locale >= 1.0.0.5 && < 1.1 default-language: Haskell98 @@ -39,13 +39,15 @@ other-modules: RegressionsSpec RobotSpec SmokeSpec - build-depends: base >= 4 && <= 5 - , hspec - , QuickCheck - , bytestring - , robots-txt - , directory - , transformers - , attoparsec - , heredoc + build-tool-depends: + hspec-discover:hspec-discover + build-depends: base >= 4 && < 5 + , hspec < 3 + , QuickCheck < 3 + , bytestring < 0.13 + , robots-txt < 0.5 + , directory < 1.4 + , transformers < 0.7 + , attoparsec < 0.15 + , heredoc < 0.3 default-language: Haskell98 diff --git a/src/Network/HTTP/Robots.hs b/src/Network/HTTP/Robots.hs --- a/src/Network/HTTP/Robots.hs +++ b/src/Network/HTTP/Robots.hs @@ -1,26 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} + module Network.HTTP.Robots where -import Control.Applicative -import Control.Monad -import Data.Attoparsec.ByteString.Char8 hiding (skipSpace) -import qualified Data.Attoparsec.Text as AT (isEndOfLine) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Char (toUpper) -import Data.Either (partitionEithers) -import Data.List (find) -import Data.Maybe (catMaybes) -import Data.Ratio -import Data.Time.Clock -import Data.Time.LocalTime () +import Control.Applicative +import Control.Monad +import Data.Attoparsec.ByteString.Char8 hiding (skipSpace) +import qualified Data.Attoparsec.Text as AT (isEndOfLine) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Char (toUpper) +import Data.Either (partitionEithers) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Ratio +import Data.Time.Clock +import Data.Time.LocalTime () type Robot = ([([UserAgent], [Directive])], [Unparsable]) type Unparsable = ByteString data UserAgent = Wildcard | Literal ByteString - deriving (Show,Eq) + deriving (Show, Eq) + type Path = ByteString -- http://www.conman.org/people/spc/robots2.html @@ -32,31 +34,32 @@ -- 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 { 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) +data Directive + = Allow Path + | Disallow Path + | 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 + (bs, _) <- match scientific if BS.elem 'e' bs || BS.elem 'E' bs then mzero else subParser rational bs @@ -65,57 +68,66 @@ -- 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 +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 :: Parser (Integer, Integer) parseHourMinute = parseWithColon <|> parseWithoutColon where parseWithColon = do hours <- skipSpace >> decimal - void $ skipSpace >> char ':' - mins <- skipSpace >> decimal - return (hours,mins) + 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) + 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)) + 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 - ) +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 '/' + 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) + 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 + return $ CrawlDelay (0 % 1) tint parseCrawlDelay :: Parser Directive parseCrawlDelay = do @@ -124,31 +136,32 @@ -- ... yeah. strip :: ByteString -> ByteString -strip = BS.reverse . BS.dropWhile (==' ') . BS.reverse . BS.dropWhile (==' ') +strip = BS.reverse . BS.dropWhile (== ' ') . BS.reverse . BS.dropWhile (== ' ') -- | parseRobots is the main entry point for parsing a robots.txt file. parseRobots :: ByteString -> Either String Robot parseRobots input = case parsed of -- special case no parsable lines and rubbish - Right ([], out@(_:_)) -> + Right ([], out@(_ : _)) -> Left ("no parsable lines: " ++ show out) _ -> parsed - - where parsed = parseOnly robotP - . BS.unlines - -- 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 . 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 windows newlines ever - . BS.filter (/= '\r') - . dropUTF8BOM - $ input + where + parsed = + parseOnly robotP + . BS.unlines + -- 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 . 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 windows newlines ever + . BS.filter (/= '\r') + . dropUTF8BOM + $ input robotP :: Parser Robot robotP = do @@ -158,80 +171,97 @@ unparsableP :: Parser ByteString unparsableP = takeTill AT.isEndOfLine <* endOfLine -- char '\n' -agentDirectiveP :: Parser ([UserAgent],[Directive]) +agentDirectiveP :: Parser ([UserAgent], [Directive]) agentDirectiveP = (,) <$> many1 agentP <*> many1 directiveP "agentDirective" - skipSpace :: Parser () -skipSpace = skipWhile (\x -> x==' ' || x == '\t') +skipSpace = skipWhile (\x -> x == ' ' || x == '\t') directiveP :: Parser Directive directiveP = do skipSpace - 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" + 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 void $ stringCI "user-agent:" skipSpace - ((string "*" >> return Wildcard) <|> - (Literal <$> tokenWithSpacesP)) <* skipSpace <* endOfLine "agent" - + ( (string "*" >> return Wildcard) + <|> (Literal <$> tokenWithSpacesP) + ) + <* skipSpace + <* endOfLine + "agent" commentsP :: Parser () -commentsP = skipSpace >> - ( (string "#" >> takeTill AT.isEndOfLine >> endOfLine) - <|> endOfLine - <|> return ()) - +commentsP = + skipSpace + >> ( (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 +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 +canAccess agent (robot, _) path = case stanzas of [] -> True - ((_,directives):_) -> matchingDirective directives - where stanzas = catMaybes [find (any (`isLiteralSubstring` agent) . fst) robot, - find ((Wildcard `elem`) . fst) robot] - - - isLiteralSubstring (Literal a) us = a `BS.isInfixOf` us - isLiteralSubstring _ _ = False - matchingDirective [] = True - matchingDirective (x:xs) = case x of - Allow robot_path -> - robot_path `BS.isPrefixOf` path || matchingDirective xs - Disallow robot_path -> - not (robot_path `BS.isPrefixOf` path) && matchingDirective xs + ((_, directives) : _) -> matchingDirective directives + where + stanzas = + catMaybes + [ find (any (`isLiteralSubstring` agent) . fst) robot, + find ((Wildcard `elem`) . fst) robot + ] - _ -> matchingDirective xs + isLiteralSubstring (Literal a) us = a `BS.isInfixOf` us + isLiteralSubstring _ _ = False + matchingDirective [] = True + matchingDirective (x : xs) = case x of + Allow robot_path -> + robot_path `BS.isPrefixOf` path || matchingDirective xs + Disallow robot_path -> + not (robot_path `BS.isPrefixOf` path) && matchingDirective xs + _ -> matchingDirective xs