meta-externalagent, stop crawling all the ?eid= URLs

1 files changed, 30 insertions, 13 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 77dfa29..7cd2c65 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -426,6 +426,20 @@ page404 message = return $ responseLBS
   [("Content-Type", "text/plain")]
   message
 
+prefilter :: Request -> Maybe Response
+prefilter req
+  -- Facebook should stop crawling all the individual ?eid=... URLs
+  | case lookup "user-agent" (reqHeaders req) of
+      Just ua | BS.take 18 ua == "meta-externalagent" -> True
+      _ -> False
+  , any ((== "eid") . fst) (reqQuery req)
+  = Just $ responseBS (Status 303 "See Other")
+                      [("Location", BS.takeWhile (/= fromIntegral (ord '?')) (reqURI req))]
+                      BS.empty
+
+  | otherwise
+  = Nothing
+
 mainServe :: FilePath -> IO ()
 mainServe confpath = do
   config <- enrichConfig <$> readConfig confpath
@@ -437,19 +451,22 @@ mainServe confpath = do
   let settings = defaultSettings { setPort = confPort config }
 
   atomicPrintS $ "Listening on port " ++ show (confPort config)
-  run settings $ \req -> case reqPath req of
-    [] ->
-      pageIndex config
-    ["log", TE.decodeUtf8' -> Right alias] ->
-      pageLog config index req alias
-    ["cal", TE.decodeUtf8' -> Right alias] ->
-      pageCalendar config index alias
-    ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] ->
-      pageCalendarDay config index req alias date
-    [fname] | fname `elem` staticFiles ->
-      return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname)
-    _ ->
-      page404 "URL not found"
+  run settings $ \req ->
+    case prefilter req of
+      Just res -> return res
+      Nothing -> case reqPath req of
+        [] ->
+          pageIndex config
+        ["log", TE.decodeUtf8' -> Right alias] ->
+          pageLog config index req alias
+        ["cal", TE.decodeUtf8' -> Right alias] ->
+          pageCalendar config index alias
+        ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] ->
+          pageCalendarDay config index req alias date
+        [fname] | fname `elem` staticFiles ->
+          return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname)
+        _ ->
+          page404 "URL not found"
 
 testParseLog :: FilePath -> IO ()
 testParseLog fname = print =<< parseLog <$> BS.readFile fname