Merge pull request #171 from aelve/referrers

Show referrers better
2024-12-22 20:31:31 +03:00 · 2017-07-09 19:30:48 -03:00 · 2017-07-09 19:30:48 -03:00 · abce5536b4
commit abce5536b4
parent b516ecd2e6 929befb081
7 changed files with 119 additions and 32 deletions
--- a/guide.cabal
+++ b/guide.cabal
@ -135,7 +135,7 @@ library
                     , stm-containers >= 0.2.14 && < 0.3
                     , template-haskell
                     , text
-                     , text-all == 0.3.*
+                     , text-all >= 0.4.1.0 && < 0.5
                     , time >= 1.5
                     , transformers
                     , unix
@ -189,7 +189,7 @@ test-suite tests
                     , quickcheck-text < 0.2
                     , slave-thread
                     , tagsoup < 1
-                     , text-all < 0.4
+                     , text-all
                     , transformers
                     , webdriver >= 0.8.4 && < 0.9
  hs-source-dirs:      tests
--- a/src/Guide/Main.hs
+++ b/src/Guide/Main.hs
@ -232,20 +232,20 @@ guideApp waiMetrics = do
              guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue");
            |]
        js <- getJS
-        Spock.bytes $ T.encodeUtf8 (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
+        Spock.bytes $ T.toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
      -- CSS
      Spock.get "/highlight.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
-        Spock.bytes $ T.encodeUtf8 (T.pack (styleToCss pygments))
+        Spock.bytes $ T.toByteString (styleToCss pygments)
      Spock.get "/css.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
-        Spock.bytes $ T.encodeUtf8 css
+        Spock.bytes $ T.toByteString css
      Spock.get "/admin.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
        admincss <- liftIO $ T.readFile "static/admin.css"
-        Spock.bytes $ T.encodeUtf8 (css <> admincss)
+        Spock.bytes $ T.toByteString (css <> admincss)

      -- Main page
      Spock.get root $
@ -331,7 +331,8 @@ loginAction = do
      formHtml <- protectForm loginFormView v
      lucidWithConfig $ renderRegister formHtml
    (v, Just Login {..}) -> do
-      loginAttempt <- dbQuery $ LoginUser loginEmail (T.encodeUtf8 loginUserPassword)
+      loginAttempt <- dbQuery $
+        LoginUser loginEmail (T.toByteString loginUserPassword)
      case loginAttempt of
        Just user -> do
          modifySession (sessionUserID .~ Just (user ^. userID))
@ -354,7 +355,8 @@ signupAction = do
      formHtml <- protectForm registerFormView v
      lucidWithConfig $ renderRegister formHtml
    (v, Just UserRegistration {..}) -> do
-      user <- makeUser registerUserName registerUserEmail (T.encodeUtf8 registerUserPassword)
+      user <- makeUser registerUserName registerUserEmail
+                       (T.toByteString registerUserPassword)
      success <- dbUpdate $ CreateUser user
      if success
        then do
@ -442,6 +444,6 @@ installTerminationCatcher thread = void $ do
 -- The user won't be added if it exists already.
 createAdminUser :: GuideApp ()
 createAdminUser = do
-  pass <- T.encodeUtf8 . _adminPassword <$> getConfig
+  pass <- T.toByteString . _adminPassword <$> getConfig
  user <- makeUser "admin" "admin@guide.aelve.com" pass
  void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True)
--- a/src/Guide/Markdown.hs
+++ b/src/Guide/Markdown.hs
@ -97,9 +97,9 @@ renderMD :: [MD.Node] -> ByteString
 renderMD ns
  -- See https://github.com/jgm/cmark/issues/147
  | any isInlineNode ns =
-      T.encodeUtf8 . sanitize . T.concat . map (nodeToHtml []) $ ns
+      T.toByteString . sanitize . T.concat . map (nodeToHtml []) $ ns
  | otherwise =
-      T.encodeUtf8 . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns
+      T.toByteString . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns

 isInlineNode :: MD.Node -> Bool
 isInlineNode (MD.Node _ tp _) = case tp of
@ -301,11 +301,11 @@ instance Show MarkdownTree where
 instance A.ToJSON MarkdownInline where
  toJSON md = A.object [
    "text" A..= (md^.mdText),
-    "html" A..= T.decodeUtf8 (md^.mdHtml) ]
+    "html" A..= T.toStrict (md^.mdHtml) ]
 instance A.ToJSON MarkdownBlock where
  toJSON md = A.object [
    "text" A..= (md^.mdText),
-    "html" A..= T.decodeUtf8 (md^.mdHtml) ]
+    "html" A..= T.toStrict (md^.mdHtml) ]
 instance A.ToJSON MarkdownTree where
  toJSON md = A.object [
    "text" A..= (md^.mdText) ]
--- a/src/Guide/Utils.hs
+++ b/src/Guide/Utils.hs
@ -31,6 +31,10 @@ module Guide.Utils
  makeSlug,
  (//),

+  -- * Referrers
+  ReferrerView (..),
+  toReferrerView,
+
  -- * IP
  sockAddrToIP,

@ -93,7 +97,8 @@ import Language.Haskell.TH
 -- needed for 'sanitiseUrl'
 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Network.URI as URI
-
+-- needed for parsing urls
+import Network.HTTP.Types (Query, parseQuery)

 ----------------------------------------------------------------------------
 -- Lists
@ -195,6 +200,83 @@ appends backslashes (@\@) and not slashes (@/@).
 (//) x y = fromMaybe x (T.stripSuffix "/" x) <> "/" <>
           fromMaybe y (T.stripPrefix "/" y)

+----------------------------------------------------------------------------
+-- ReferrerView
+----------------------------------------------------------------------------
+
+data SearchEngine
+  = Google
+  | Yandex
+  | Yahoo
+  | Bing
+  | Ecosia
+  | DuckDuckGo
+  deriving (Show, Eq, Ord)
+
+-- | Check whether a domain is one of known search engines.
+--
+-- TODO: this gives some false positives, e.g. @google.wordpress.com@ or
+-- @blog.google@ will be erroneously detected as search engines.
+toSearchEngine
+  :: Text                 -- ^ Domain
+  -> Maybe SearchEngine
+toSearchEngine t
+  | "google" `elem` lst = Just Google
+  | "yandex" `elem` lst = Just Yandex
+  | "yahoo"  `elem` lst = Just Yahoo
+  | "bing"   `elem` lst = Just Bing
+  | "ecosia" `elem` lst = Just Ecosia
+  | "duckduckgo" `elem` lst = Just DuckDuckGo
+  | otherwise = Nothing
+  where lst = T.splitOn "." t
+
+-- | A (lossy) representation of referrers that is better for analytics.
+data ReferrerView
+  = RefSearchEngine { searchEngine :: SearchEngine
+                    , keyword      :: Text }  -- No keyword = empty keyword
+  | RefUrl Url
+  deriving (Eq, Ord)
+
+instance Show ReferrerView where
+  show (RefSearchEngine searchEngine keyword)
+    = show searchEngine <> showKeyword keyword
+  show (RefUrl url) = T.toString url
+
+showKeyword :: Text -> String
+showKeyword "" = ""
+showKeyword kw = " (\"" <> T.toString kw <> "\")"
+
+extractQuery :: Url -> Maybe Query
+extractQuery url = getQuery <$> parse url
+  where
+    getQuery = parseQuery . T.toByteString . URI.uriQuery
+    parse = URI.parseURI . T.toString
+
+-- TODO: different search engines have different parameters, we should use
+-- right ones instead of just trying “whatever fits”
+extractKeyword :: Url -> Maybe Text
+extractKeyword url
+  = case extractQuery url of
+      Just query -> T.toStrict <$> lookupQuery query
+      Nothing    -> Nothing
+  where
+    lookupQuery :: [(ByteString, Maybe ByteString)] -> Maybe ByteString
+    lookupQuery query = join $
+      lookup "q"    query <|>     -- Google, Bing, Ecosia, DDG
+      lookup "p"    query <|>     -- Yahoo
+      lookup "text" query         -- Yandex
+
+toReferrerView :: Url -> ReferrerView
+toReferrerView url
+  = case toSearchEngine =<< domain of
+      Just se -> RefSearchEngine se (fromMaybe "" keyword)
+      Nothing -> RefUrl url
+  where
+    uri = URI.parseURI $ T.toString url
+    uriAuth = URI.uriAuthority =<< uri
+    domain = T.toStrict . URI.uriRegName <$> uriAuth
+    keyword = extractKeyword url
+
 ----------------------------------------------------------------------------
 -- IP
 ----------------------------------------------------------------------------
@ -228,7 +310,7 @@ instance SafeCopy (Uid a) where
  kind = base

 instance IsString (Uid a) where
-  fromString = Uid . T.pack
+  fromString = Uid . T.toStrict

 -- | Generate a random text of given length from characters @a-z@ and digits.
 randomText :: MonadIO m => Int -> m Text
@ -242,7 +324,7 @@ randomText n = liftIO $ do
        return $ if i < 10 then toEnum (fromEnum '0' + i)
                           else toEnum (fromEnum 'a' + i - 10)
  xs <- replicateM (n-1) randomChar
-  return (T.pack (x:xs))
+  return (T.toStrict (x:xs))

 -- For probability tables, see
 -- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
@ -297,7 +379,7 @@ includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
 atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m ()
 atomFeed feed = do
  setHeader "Content-Type" "application/atom+xml; charset=utf-8"
-  bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))
+  bytes $ T.toByteString (XML.ppElement (Atom.xmlFeed feed))

 -- | Get details of the request:
 --
--- a/src/Guide/Views.hs
+++ b/src/Guide/Views.hs
@ -60,7 +60,6 @@ import qualified Guide.Diff as Diff
 import Guide.Cache
 import Guide.Views.Utils

-
 {- Note [autosize]
 ~~~~~~~~~~~~~~~~~~

@ -238,7 +237,8 @@ renderStats globalState acts = do
      th_ "Visits"
      th_ "Unique visitors"
    tbody_ $ do
-      let rawVisits :: [(Uid Category, Maybe IP)]
+      let rawVisits :: [(Uid Category, Maybe IP
+                        )]
          rawVisits = [(catId, actionIP d) |
                       (Action'CategoryVisit catId, d) <- acts']
      let visits :: [(Uid Category, (Int, Int))]
@ -269,19 +269,21 @@ renderStats globalState acts = do
      th_ "Unique visitors"
    tbody_ $ do
      let rawVisits :: [(Url, Maybe IP)]
-          rawVisits = [(r, actionIP d) |
-                       (_, d) <- acts',
-                       Just (ExternalReferrer r) <- [actionReferrer d]]
-      let visits :: [(Url, (Int, Int))]
-          visits = map (over _2 (length &&& length.ordNub)) .
-                   map (fst.head &&& map snd) .
-                   groupWith fst
-                     $ rawVisits
+          rawVisits = [(r, actionIP d)
+                         | d <- map snd acts'
+                         , Just (ExternalReferrer r) <- [actionReferrer d]]
+      let sortRefs :: [(Url, Maybe IP)] -> [(ReferrerView, [Maybe IP])]
+          sortRefs = map (fst.head &&& map snd)
+                   . groupWith fst
+                   . map (over _1 toReferrerView)
+      let visits :: [(ReferrerView, (Int, Int))]
+          visits = map (over _2 (length &&& length.ordNub))
+                       (sortRefs rawVisits)
      for_ (reverse $ sortWith (fst.snd) visits) $ \(r, (n, u)) -> do
        tr_ $ do
-          td_ (toHtml r)
-          td_ (toHtml (show n))
-          td_ (toHtml (show u))
+          td_ (toHtml (show r))  -- referrer
+          td_ (toHtml (show n))  -- visitors
+          td_ (toHtml (show u))  -- unique visitors
  table_ $ do
    thead_ $ tr_ $ do
      th_ "Action"
--- a/src/Guide/Views/Utils.hs
+++ b/src/Guide/Views/Utils.hs
@ -70,7 +70,6 @@ import qualified Data.Map as M
 -- import Data.Tree
 -- Text
 import qualified Data.Text.All as T
-import qualified Data.Text.Lazy.All as TL
 -- digestive-functors
 import Text.Digestive (View)
 -- import NeatInterpolation
@ -87,6 +86,7 @@ import qualified System.FilePath.Find as F
 -- Mustache (templates)
 import Text.Mustache.Plus
 import qualified Data.Aeson as A
+import qualified Data.Aeson.Text as A
 import qualified Data.Aeson.Encode.Pretty as A
 import qualified Data.ByteString.Lazy.Char8 as BS
 import qualified Data.Semigroup as Semigroup
@ -297,7 +297,7 @@ mustache f v = do
            then return (A.String "selected")
            else return A.Null),
        ("js", \[x] -> return $
-            A.String . T.toStrict . TL.decodeUtf8 . A.encode $ x),
+            A.String . T.toStrict . A.encodeToLazyText $ x),
        ("trace", \xs -> do
            mapM_ (BS.putStrLn . A.encodePretty) xs
            return A.Null) ]
--- a/stack.yaml
+++ b/stack.yaml
@ -12,6 +12,7 @@ packages:
  extra-dep: true

 extra-deps:
+- text-all-0.4.1.0
 - cmark-sections-0.1.0.3
 - patches-vector-0.1.5.4
 - fmt-0.2.0.0