robots-txt 0.1.0.3 → 0.2.0.0

raw patch · 2 files changed

+47/−8 lines, 2 filesdep +heredoc

Dependencies added: heredoc

Files

• robots-txt.cabal +2/−1
• src/Network/HTTP/Robots.hs +45/−7

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                robots-txt-version:             0.1.0.3+version:             0.2.0.0 synopsis:            Parser for robots.txt description:         This is an attoparsec parser for robots.txt files homepage:            http://github.com/meanpath/robots@@ -41,3 +41,4 @@                    , directory                    , transformers                    , attoparsec+                   , heredoc

@@ -3,10 +3,12 @@  import qualified Data.ByteString.Char8 as BS import           Data.ByteString.Char8(ByteString)-import Data.Attoparsec.Char8+import Data.Attoparsec.Char8 hiding (skipSpace) import Control.Applicative+import Data.List(find)+import Data.Maybe(catMaybes) -type Robot = [(UserAgent, [Directive])]+type Robot = [([UserAgent], [Directive])]  data UserAgent = Wildcard | Literal ByteString   deriving (Show,Eq)@@ -25,21 +27,57 @@               . BS.lines  robotP :: Parser Robot-robotP = many ((,) <$> agentP <*> many directiveP) <?> "robot"+robotP = many ((,) <$> many1 agentP <*> many1 directiveP) <?> "robot" +skipSpace :: Parser ()+skipSpace = skipWhile (\x -> x==' ' || x == '\t')  directiveP :: Parser Directive directiveP = choice [ Allow <$>      (string "Allow:"       >> skipSpace >> tokenP)-                    , Disallow <$>   (string "Disallow:"    >> skipSpace >> tokenP)+                    , (string "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 <$> (string "Crawl-delay:" >>  skipSpace >>decimal)-                    ] <* skipSpace <?> "directive"+                    ] <* commentsP <?> "directive"  agentP :: Parser UserAgent agentP = do   string "User-agent:"   skipSpace   ((string "*" >> return Wildcard) <|>-   (Literal  <$> tokenP)) <* skipSpace <?> "agent"+   (Literal  <$> tokenP)) <* skipSpace <* endOfLine <?> "agent" ++commentsP :: Parser ()+commentsP = skipSpace >>+            ((string "#" >> takeTill (=='\n') >> skipSpace >> endOfLine) <|> return ())+ tokenP :: Parser ByteString-tokenP = skipSpace >> takeTill isSpace <* skipSpace+tokenP = skipSpace >> takeWhile1 (not . isSpace) <* skipSpace++-- I lack the art to make this prettier.+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 ((Literal agent `elem`) . fst) robot,+                             find ((Wildcard `elem`) . fst) robot]+        matchingDirective [] = True+        matchingDirective (x:xs) = case x of+          Allow robot_path -> if robot_path `BS.isPrefixOf` path+                              then True+                              else matchingDirective xs+          Disallow robot_path ->+            if robot_path `BS.isPrefixOf` path+            then False+            else matchingDirective xs+          _ -> matchingDirective xs