<commit_before>-- Copyright 2010, 2011 <NAME>

-- This file is part of Vocabulink.

-- Vocabulink is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.

-- Vocabulink is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-- A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.

-- You should have received a copy of the GNU Affero General Public License
-- along with Vocabulink. If not, see <http://www.gnu.org/licenses/>.

module Vocabulink.Page ( stdPage, simplePage
                       , currentPage, pager
                       ) where

import Vocabulink.App
import Vocabulink.Article
import Vocabulink.CGI
import Vocabulink.Form
import Vocabulink.Html hiding (title)
import Vocabulink.Member
import Vocabulink.Utils

import Data.List (partition)
import Text.Blaze.Html5 (docTypeHtml, head, noscript, link, body, title)
import Text.Blaze.Html5.Attributes (rel)
import Text.Regex (mkRegex, subRegex)
import Text.Regex.TDFA ((=~))

import Prelude hiding (div, span, id, head)

-- |stdPage| takes a title, a list of dependencies, and list of HTML objects to
-- place into the body of the page. It automatically adds a standard header and
-- footer. It also includes @page.css@ and conditionally includes an Internet
-- Explorer-specific stylesheet for the few cases when there's no other way to
-- work around a defect in Internet Explorer that would otherwise seriously impact
-- usability.

-- If any JavaScript files are required, |stdPage| will automatically add a
-- @<noscript>@ warning to the top of the page.

stdPage :: String -> [Dependency] -> Html -> Html -> App CGIResult
stdPage title' deps head' body' = outputHtml =<< (do
  headerB <- headerBar
  footerB <- footerBar
  member <- asks appMember
  let deps' = [CSS "lib.common", JS "lib.common"]
           ++ (isJust member ? [CSS "lib.member", JS "lib.member"] $ [])
           ++ deps
      (cssDeps, jsDeps) = partition (\x -> case x of
                                             (CSS _) -> True
                                             (JS  _) -> False) deps'
  cssDeps' <- mapM includeDep cssDeps
  jsDeps'  <- mapM includeDep jsDeps
  return $ docTypeHtml $ do
    head $ do
      mconcat cssDeps'
      title $ string title'
      link ! rel "icon" ! type_ "image/png" ! href "http://s.vocabulink.com/img/favicon.png"
      head'
    body $ do
      script ! src "http://www.google-analytics.com/ga.js" $ mempty
      mconcat jsDeps'
      div ! id "head" $ headerB
      when (jsDeps /= []) (noscript $ p $ "This page requires JavaScript for some functionality.")
      div ! id "body" $ body'
      div ! id "foot" $ footerB)

-- Often we just need a simple page where the title and header are the same.

simplePage :: String -> [Dependency] -> Html -> App CGIResult
simplePage t deps body' = stdPage t deps mempty $ mappend (h1 $ string t) body'

-- Each dependency is expressed as the path from the root of the static files
-- subdomain (for now, @s.vocabulink.com@) to the file. Do not include the file
-- suffix (@.css@ or @.js@); it will be appended automatically. These are meant
-- for inclusion in the @<head>@ of the page.

-- |includeDep| also needs to check dependency versions for cache busting.

includeDep :: Dependency -> App Html
includeDep d = do
  version <- dependencyVersion d
  return $ case version of
    Nothing -> script ! type_ "text/javascript" $
                  preEscapedString ("alert('Dependency \"" ++ show d ++"\" not found.');")
    Just v  ->
      case d of
        CSS css -> link ! href (stringValue $ "http://s.vocabulink.com/css/" ++ css ++ ".css?" ++ v)
                        ! rel "stylesheet"
                        ! type_ "text/css"
        JS  js  -> script ! src (stringValue $ "http://s.vocabulink.com/js/" ++ js ++ ".js?" ++ v) $
                     mempty

-- The standard header bar shows the Vocabulink logo (currently just some
-- text), a list of hyperlinks, a search box, and either a login/sign up button
-- or a logout button. If the page is being served to a logged-in member it
-- also includes a notice about the number of links that the member has waiting
-- for review.

headerBar :: App Html
headerBar = do
  member <- asks appMember
  review <- case member of
              Nothing -> return mempty
              Just m  -> reviewBox <$> numLinksToReview m
  return $ do
    a ! href "/" ! accesskey "1" $
      img ! class_ "logo" ! alt "Vocabulink: Learn Languages through Fiction"
                          ! src "http://s.vocabulink.com/img/logo-compact.png"
    div ! id "head-decoration" $ mempty
    div ! id "head-bar" $ do
      searchBox
      review
      maybe loginBox logoutBox member
    clear

-- The footer displays a number of common (or what we believe to be common)
-- hyperlinks for English speakers.

languageLinks :: App [Html]
languageLinks = do
  rows' <- $(queryTuples' "SELECT abbr, name \
                          \FROM language_frequency_to_english \
                          \ORDER BY freq DESC LIMIT 7")
  return $ map languageLink rows' ++ [a ! href "/languages" $ "more..."]
 where languageLink (abbr', name') =
         a ! href (stringValue $ "/links?ol=" ++ fromJust abbr' ++ "&dl=en") $
           string $ fromJust name'

footerBar :: App Html
footerBar = do
  langLinks <- languageLinks
  articles <- (map articleLinkHtml . take 3) <$> getArticles
  forums <- footerForums
  copy <- liftIO $ copyrightNotice
  return $ do
    multiColumn [ do h2 $ a ! href "/languages" $ "Browse Links by Language"
                     multiColumnList 2 langLinks
                , do h2 $ a ! href "/articles" $ "Latest Articles"
                     multiColumnList 1 (articles ++ [a ! href "/articles" $ "more..."])
                , do h2 $ a ! href "/forums" $ "Forums"
                     multiColumnList 2 (forums ++ [a ! href "/forums" $ "more..."])
                ] ! id "handy-links"
    unordList [ a ! href "/help" $ "help"
              , a ! href "/privacy" $ "privacy policy"
              , a ! href "/terms-of-use" $ "terms of use"
              , a ! href "/source" $ "source"
              ] ! class_ "hyperlinks"
    p $ do
      copy
      span ! id "design-attribution" $ do
        string "Design by: "
        a ! href "http://www.designcharisma.com" $ "Design Charisma"
 where articleLinkHtml article =
         a ! href (stringValue $ "/article/" ++ articleFilename article) $
           string $ articleTitle article

footerForums :: App [Html]
footerForums = do
  rows' <- $(queryTuples' "SELECT name, title FROM forum \
                          \WHERE group_name = 'Vocabulink'")
  return $ map forumLink rows'
 where forumLink (name', title') =
         a ! href (stringValue $ "/forum/" ++ name') $ string title'

-- We want a copyright notice at the bottom of every page. Since this is a
-- copyright notice for dynamic content, we want it to be up-to-date with the
-- generation time (now).

copyrightNotice :: IO Html
copyrightNotice = do
  year <- currentYear
  return $ span ! class_ "copyright" $ do
    string "Copyright 2008–"
    string (show year ++ " ")
    a ! href "http://jekor.com/" $ "<NAME>"

-- The following are just login and signup buttons.

loginBox :: Html
loginBox = span ! class_ "auth-box login" $ do
  a ! id "login-button" ! class_ "button dark" $ "Log in"
  string " | "
  a ! href "/member/signup" $ "Sign up"

-- For logged-in members, we provide a logout button (with an indicator of your
-- username to show that you're logged in).

logoutBox :: Member -> Html
logoutBox member = form ! class_ "auth-box logout" ! action "/member/logout" ! method "post" $ do
  string $ memberName member
  input ! type_ "submit" ! id "logout-button" ! class_ "button dark" ! value "Log Out"

-- Students with a goal in mind will want to search for words they're studying
-- rather than browse randomly. We display a search box for them at the top of the
-- page. This also is currently the only way to create new links (aside from
-- entering in the URL manually), but that might change in the future.

-- Currently, this uses a combination of our search logic and Google Custom Search.

searchBox :: Html
searchBox = form ! id "cse-search-box" ! class_ "search-box" ! action "/search" $ do
  div $ do
    input ! type_ "hidden" ! name "cx" ! value "011479832181784786223:2ibwsl9f6ca"
    input ! type_ "hidden" ! name "cof" ! value "FORID:9"
    input ! type_ "hidden" ! name "ie" ! value "UTF-8"
    input ! type_ "search" ! name "q" ! accesskey "s"
    string " "
    input ! type_ "submit" ! id "sa" ! name "sa" ! class_ "button dark" ! value "Search"
  script ! src "http://www.google.com/cse/brand?form=cse-search-box&lang=en" $ mempty
<commit_msg>Making the username in the logout box clickable.<commit_after>-- Copyright 2010, 2011 <NAME>

-- This file is part of Vocabulink.

-- Vocabulink is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.

-- Vocabulink is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-- A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.

-- You should have received a copy of the GNU Affero General Public License
-- along with Vocabulink. If not, see <http://www.gnu.org/licenses/>.

module Vocabulink.Page ( stdPage, simplePage
                       , currentPage, pager
                       ) where

import Vocabulink.App
import Vocabulink.Article
import Vocabulink.CGI
import Vocabulink.Form
import Vocabulink.Html hiding (title)
import Vocabulink.Member
import Vocabulink.Utils

import Data.List (partition)
import Text.Blaze.Html5 (docTypeHtml, head, noscript, link, body, title)
import Text.Blaze.Html5.Attributes (rel)
import Text.Regex (mkRegex, subRegex)
import Text.Regex.TDFA ((=~))

import Prelude hiding (div, span, id, head)

-- |stdPage| takes a title, a list of dependencies, and list of HTML objects to
-- place into the body of the page. It automatically adds a standard header and
-- footer. It also includes @page.css@ and conditionally includes an Internet
-- Explorer-specific stylesheet for the few cases when there's no other way to
-- work around a defect in Internet Explorer that would otherwise seriously impact
-- usability.

-- If any JavaScript files are required, |stdPage| will automatically add a
-- @<noscript>@ warning to the top of the page.

stdPage :: String -> [Dependency] -> Html -> Html -> App CGIResult
stdPage title' deps head' body' = outputHtml =<< (do
  headerB <- headerBar
  footerB <- footerBar
  member <- asks appMember
  let deps' = [CSS "lib.common", JS "lib.common"]
           ++ (isJust member ? [CSS "lib.member", JS "lib.member"] $ [])
           ++ deps
      (cssDeps, jsDeps) = partition (\x -> case x of
                                             (CSS _) -> True
                                             (JS  _) -> False) deps'
  cssDeps' <- mapM includeDep cssDeps
  jsDeps'  <- mapM includeDep jsDeps
  return $ docTypeHtml $ do
    head $ do
      mconcat cssDeps'
      title $ string title'
      link ! rel "icon" ! type_ "image/png" ! href "http://s.vocabulink.com/img/favicon.png"
      head'
    body $ do
      script ! src "http://www.google-analytics.com/ga.js" $ mempty
      mconcat jsDeps'
      div ! id "head" $ headerB
      when (jsDeps /= []) (noscript $ p $ "This page requires JavaScript for some functionality.")
      div ! id "body" $ body'
      div ! id "foot" $ footerB)

-- Often we just need a simple page where the title and header are the same.

simplePage :: String -> [Dependency] -> Html -> App CGIResult
simplePage t deps body' = stdPage t deps mempty $ mappend (h1 $ string t) body'

-- Each dependency is expressed as the path from the root of the static files
-- subdomain (for now, @s.vocabulink.com@) to the file. Do not include the file
-- suffix (@.css@ or @.js@); it will be appended automatically. These are meant
-- for inclusion in the @<head>@ of the page.

-- |includeDep| also needs to check dependency versions for cache busting.

includeDep :: Dependency -> App Html
includeDep d = do
  version <- dependencyVersion d
  return $ case version of
    Nothing -> script ! type_ "text/javascript" $
                  preEscapedString ("alert('Dependency \"" ++ show d ++"\" not found.');")
    Just v  ->
      case d of
        CSS css -> link ! href (stringValue $ "http://s.vocabulink.com/css/" ++ css ++ ".css?" ++ v)
                        ! rel "stylesheet"
                        ! type_ "text/css"
        JS  js  -> script ! src (stringValue $ "http://s.vocabulink.com/js/" ++ js ++ ".js?" ++ v) $
                     mempty

-- The standard header bar shows the Vocabulink logo (currently just some
-- text), a list of hyperlinks, a search box, and either a login/sign up button
-- or a logout button. If the page is being served to a logged-in member it
-- also includes a notice about the number of links that the member has waiting
-- for review.

headerBar :: App Html
headerBar = do
  member <- asks appMember
  review <- case member of
              Nothing -> return mempty
              Just m  -> reviewBox <$> numLinksToReview m
  return $ do
    a ! href "/" ! accesskey "1" $
      img ! class_ "logo" ! alt "Vocabulink: Learn Languages through Fiction"
                          ! src "http://s.vocabulink.com/img/logo-compact.png"
    div ! id "head-decoration" $ mempty
    div ! id "head-bar" $ do
      searchBox
      review
      maybe loginBox logoutBox member
    clear

-- The footer displays a number of common (or what we believe to be common)
-- hyperlinks for English speakers.

languageLinks :: App [Html]
languageLinks = do
  rows' <- $(queryTuples' "SELECT abbr, name \
                          \FROM language_frequency_to_english \
                          \ORDER BY freq DESC LIMIT 7")
  return $ map languageLink rows' ++ [a ! href "/languages" $ "more..."]
 where languageLink (abbr', name') =
         a ! href (stringValue $ "/links?ol=" ++ fromJust abbr' ++ "&dl=en") $
           string $ fromJust name'

footerBar :: App Html
footerBar = do
  langLinks <- languageLinks
  articles <- (map articleLinkHtml . take 3) <$> getArticles
  forums <- footerForums
  copy <- liftIO $ copyrightNotice
  return $ do
    multiColumn [ do h2 $ a ! href "/languages" $ "Browse Links by Language"
                     multiColumnList 2 langLinks
                , do h2 $ a ! href "/articles" $ "Latest Articles"
                     multiColumnList 1 (articles ++ [a ! href "/articles" $ "more..."])
                , do h2 $ a ! href "/forums" $ "Forums"
                     multiColumnList 2 (forums ++ [a ! href "/forums" $ "more..."])
                ] ! id "handy-links"
    unordList [ a ! href "/help" $ "help"
              , a ! href "/privacy" $ "privacy policy"
              , a ! href "/terms-of-use" $ "terms of use"
              , a ! href "/source" $ "source"
              ] ! class_ "hyperlinks"
    p $ do
      copy
      span ! id "design-attribution" $ do
        string "Design by: "
        a ! href "http://www.designcharisma.com" $ "Design Charisma"
 where articleLinkHtml article =
         a ! href (stringValue $ "/article/" ++ articleFilename article) $
           string $ articleTitle article

footerForums :: App [Html]
footerForums = do
  rows' <- $(queryTuples' "SELECT name, title FROM forum \
                          \WHERE group_name = 'Vocabulink'")
  return $ map forumLink rows'
 where forumLink (name', title') =
         a ! href (stringValue $ "/forum/" ++ name') $ string title'

-- We want a copyright notice at the bottom of every page. Since this is a
-- copyright notice for dynamic content, we want it to be up-to-date with the
-- generation time (now).

copyrightNotice :: IO Html
copyrightNotice = do
  year <- currentYear
  return $ span ! class_ "copyright" $ do
    string "Copyright 2008–"
    string (show year ++ " ")
    a ! href "http://jekor.com/" $ "<NAME>"

-- The following are just login and signup buttons.

loginBox :: Html
loginBox = span ! class_ "auth-box login" $ do
  a ! id "login-button" ! class_ "button dark" $ "Log in"
  string " | "
  a ! href "/member/signup" $ "Sign up"

-- For logged-in members, we provide a logout button (with an indicator of your
-- username to show that you're logged in).

logoutBox :: Member -> Html
logoutBox member = form ! class_ "auth-box logout" ! action "/member/logout" ! method "post" $ do
  a ! href (stringValue $ "/member/" ++ memberName member) $ (string $ memberName member)
  input ! type_ "submit" ! id "logout-button" ! class_ "button dark" ! value "Log Out"

-- Students with a goal in mind will want to search for words they're studying
-- rather than browse randomly. We display a search box for them at the top of the
-- page. This also is currently the only way to create new links (aside from
-- entering in the URL manually), but that might change in the future.

-- Currently, this uses a combination of our search logic and Google Custom Search.

searchBox :: Html
searchBox = form ! id "cse-search-box" ! class_ "search-box" ! action "/search" $ do
  div $ do
    input ! type_ "hidden" ! name "cx" ! value "011479832181784786223:2ibwsl9f6ca"
    input ! type_ "hidden" ! name "cof" ! value "FORID:9"
    input ! type_ "hidden" ! name "ie" ! value "UTF-8"
    input ! type_ "search" ! name "q" ! accesskey "s"
    string " "
    input ! type_ "submit" ! id "sa" ! name "sa" ! class_ "button dark" ! value "Search"
  script ! src "http://www.google.com/cse/brand?form=cse-search-box&lang=en" $ mempty

{'fraction_non_alphanumeric': 0.1112707182320442, 'fraction_numerical': 0.005635359116022099, 'mean_word_length': 2.530524673298225, 'pattern_counts': {'":': 0, '<': 51, '<?xml version=': 0, '>': 53, 'https://': 0, 'lorem ipsum': 0, 'www.': 8, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1268606', 'n_tokens_mistral': 5435, 'n_tokens_neox': 5253, 'n_words': 2117}