<commit_before>{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
-------------------------------------------------------------------------------
-- |
-- Module      :  Comments
-- Copyright   :  (c) <NAME> 2010 
-- License     :  as-is
--
-- Maintainer  :  <EMAIL>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A generic Comments interface for a Yesod application.
--
-------------------------------------------------------------------------------
module Comments (commentsForm) where

import Comments.Core
import Comments.Templates
import Comments.Storage

import Yesod
import Yesod.Form.Core            (FieldProfile(..), requiredFieldHelper)
import Control.Applicative        ((<$>), (<*>))
import Data.Time.Clock            (getCurrentTime)
import Network.Wai                (remoteHost)
import Text.Hamlet                (toHtml)
import Text.HTML.SanitizeXSS      (sanitizeXSS)

import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L

-- | Cleans form input and create a comment type to be stored
commentFromForm :: String -> CommentForm -> GHandler s m Comment
commentFromForm thread cf = do
    timeNow <- liftIO getCurrentTime
    ip      <- return . B.unpack . remoteHost =<< waiRequest

    if formIsHtml cf
        then return $ Comment thread timeNow ip (formUser cf) (htmlToHtml $ formComment cf)
        else return $ Comment thread timeNow ip (formUser cf) (textToHtml $ formComment cf)
    where
        -- the user entered html source directly
        htmlToHtml :: Textarea -> Html
        htmlToHtml = preEscapedString . sanitizeXSS . stripCRLF . unTextarea
        
        -- the user intends plaintext
        textToHtml :: Textarea -> Html
        textToHtml = toHtml . liftT stripCR

        -- with html, \r\n and \n should always become space
        stripCRLF []               = []
        stripCRLF ('\r':'\n':rest) = ' ' : stripCRLF rest
        stripCRLF ('\n':rest)      = ' ' : stripCRLF rest
        stripCRLF (x:rest)         = x   : stripCRLF rest

        -- with plaintext, \n will become <br>, \r should just be discarded
        stripCR []          = []
        stripCR ('\r':rest) =     stripCR rest
        stripCR (x:rest)    = x : stripCR rest

-- | lift a String function into Textara
liftT :: (String -> String) -> (Textarea -> Textarea)
liftT f = Textarea . f . unTextarea

-- | The input form itself
commentForm :: Maybe CommentForm -> Form s m CommentForm
commentForm cf = fieldsToTable $ CommentForm
    <$> stringField  "name:"    (fmap formUser    cf)
    <*> commentField "comment:" (fmap formComment cf)
    <*> boolField    "html?"    (fmap formIsHtml  cf)

-- | todo: A copy of stringField but with custom validation
--userField :: String -> FormletField sub y String
--userField label initial = GForm $ do
--    userId   <- newFormIdent
--    userName <- newFormIdent
--    env      <- askParams
--
--    let res = undefined
--        case env of
--            [] -> FormMissing
--            _  ->
--                case (lookup userName env) of
--                    Just userString -> undefined -- validate string
--                    _               -> FormFailure "Username required."
--
--    let userValue = fromMaybe "" $ lookup userName env `mplus` initial
--    let fi = FieldInfo
--        { fiLabel = label
--        , fiTooltip = ""
--        , fiIdent = userId
--        , fiInput = [$hamlet| test |]
--        , fiErrors =
--            case res of
--                FormFailure [x] -> Just $ string x
--                _               -> Nothing
--        }
--    return (res, [fi], UrlEncoded)

-- | A copy of textareaField but with a larger entry box
commentField :: FormFieldSettings -> FormletField sub y Textarea
commentField = requiredFieldHelper textareaFieldProfile'

textareaFieldProfile' :: FieldProfile sub y Textarea
textareaFieldProfile' = FieldProfile
    { fpParse  = Right . Textarea
    , fpRender = unTextarea
    , fpWidget = \theId name val _isReq -> addBody [$hamlet|
%textarea#$theId$!name=$name$!cols=50!rows=6 $val$<commit_msg>username validation<commit_after>{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
-------------------------------------------------------------------------------
-- |
-- Module      :  Comments
-- Copyright   :  (c) <NAME> 2010 
-- License     :  as-is
--
-- Maintainer  :  <EMAIL>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A generic Comments interface for a Yesod application.
--
-------------------------------------------------------------------------------
module Comments (commentsForm) where

import Comments.Core
import Comments.Templates
import Comments.Storage

import Yesod
import Control.Applicative        ((<$>), (<*>))
import Data.Time.Clock            (getCurrentTime)
import Network.Wai                (remoteHost)
import Text.Hamlet                (toHtml)
import Text.HTML.SanitizeXSS      (sanitizeXSS)

import Yesod.Form
import Yesod.Form.Core
import Control.Monad   (mplus)
import Data.Maybe      (fromMaybe)

import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L

-- | Cleans form input and create a comment type to be stored
commentFromForm :: String -> CommentForm -> GHandler s m Comment
commentFromForm thread cf = do
    timeNow <- liftIO getCurrentTime
    ip      <- return . B.unpack . remoteHost =<< waiRequest

    if formIsHtml cf
        then return $ Comment thread timeNow ip (formUser cf) (htmlToHtml $ formComment cf)
        else return $ Comment thread timeNow ip (formUser cf) (textToHtml $ formComment cf)
    where
        -- the user entered html source directly
        htmlToHtml :: Textarea -> Html
        htmlToHtml = preEscapedString . sanitizeXSS . stripCRLF . unTextarea
        
        -- the user intends plaintext
        textToHtml :: Textarea -> Html
        textToHtml = toHtml . liftT stripCR

        -- with html, \r\n and \n should always become space
        stripCRLF []               = []
        stripCRLF ('\r':'\n':rest) = ' ' : stripCRLF rest
        stripCRLF ('\n':rest)      = ' ' : stripCRLF rest
        stripCRLF (x:rest)         = x   : stripCRLF rest

        -- with plaintext, \n will become <br>, \r should just be discarded
        stripCR []          = []
        stripCR ('\r':rest) =     stripCR rest
        stripCR (x:rest)    = x : stripCR rest

-- | lift a String function into Textara
liftT :: (String -> String) -> (Textarea -> Textarea)
liftT f = Textarea . f . unTextarea

-- | The input form itself
commentForm :: Maybe CommentForm -> Form s m CommentForm
commentForm cf = fieldsToTable $ CommentForm
    <$> userField    "name:"    (fmap formUser    cf)
    <*> commentField "comment:" (fmap formComment cf)
    <*> boolField    "html?"    (fmap formIsHtml  cf)

-- | todo: A copy of stringField but with custom validation
userField :: String -> FormletField sub y String
userField label initial = GForm $ do
    userId   <- newFormIdent
    userName <- newFormIdent
    env      <- askParams

    let res = case env of
                [] -> FormMissing
                _  ->
                    case (lookup userName env) of
                        Just userString -> 
                            if (isValid userString)
                                then FormSuccess userString
                                else FormFailure ["[a-zA-Z-_. ]"]
                        _               -> FormFailure ["Value is required"]

    let userValue = fromMaybe "" $ lookup userName env `mplus` initial
    let fi = FieldInfo { fiLabel   = string $ label
                       , fiTooltip = string $ ""
                       , fiIdent = userId
                       , fiInput = [$hamlet|
    %input#userId!name=$userName$!type=text!value=$userValue$
|]
                       , fiErrors =
                           case res of
                               FormFailure [x] -> Just $ string x
                               _               -> Nothing
                       }

    return (res, [fi], UrlEncoded)
    where
        isValid s  = not (s == []) && all (flip elem validChars) s
        validChars = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['-', '_', '.', ' ']

-- | A copy of textareaField but with a larger entry box
commentField :: FormFieldSettings -> FormletField sub y Textarea
commentField = requiredFieldHelper textareaFieldProfile'

textareaFieldProfile' :: FieldProfile sub y Textarea
textareaFieldProfile' = FieldProfile
    { fpParse  = Right . Textarea
    , fpRender = unTextarea
    , fpWidget = \theId name val _isReq -> addBody [$hamlet|
%textarea#$theId$!name=$name$!cols=50!rows=6 $val$
{'fraction_non_alphanumeric': 0.1390728476821192, 'fraction_numerical': 0.0022836263987211693, 'mean_word_length': 1.813684548666881, 'pattern_counts': {'":': 0, '<': 33, '<?xml version=': 0, '>': 53, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6144253', 'n_tokens_mistral': 2470, 'n_tokens_neox': 2388, 'n_words': 746}