{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}
-------------------------------------------------------------------------------
-- |
-- Module      :  Yesod.Comments.Core
-- Copyright   :  (c) Patrick Brisbin 2010
-- License     :  as-is
--
-- Maintainer  :  pbrisbin@gmail.com
-- Stability   :  unstable
-- Portability :  unportable
--
-------------------------------------------------------------------------------
module Yesod.Comments.Core
    ( Comment(..)
    , CommentForm(..)
    , CommentId
    , ThreadId
    , YesodComments (..)
    , Form
    , commentFromForm
    , commentForm
    , commentFormAuth
    , commentLabel
    , handleForm
    , showComments
    , showComment
    , showCommentAuth
    , getNextCommentId
    , isCommentingUser
    ) where

import Yesod
import Yesod.Auth
import Yesod.Markdown
import Control.Applicative ((<$>), (<*>), pure)
import Data.Text           (Text)
import Data.Time           (UTCTime, getCurrentTime)
import Data.Time.Format.Human
import Network.Gravatar
import Network.Wai         (remoteHost)
import qualified Data.Text as T

type ThreadId  = Text
type CommentId = Int

class Yesod m => YesodComments m where
    getComment    :: ThreadId -> CommentId -> GHandler s m (Maybe Comment)
    storeComment  :: Comment -> GHandler s m ()
    updateComment :: Comment -> Comment -> GHandler s m ()
    deleteComment :: Comment -> GHandler s m ()
    loadComments  :: Maybe ThreadId -> GHandler s m [Comment]

    -- | If using Auth, provide the function to get from a user id to
    --   the string to use as the commenter's username. This should
    --   return something friendly probably pulled from the user's
    --   profile on your site.
    displayUser :: AuthId m -> GHandler s m Text
    displayUser _ = return ""

    -- | If using Auth, provide the function to get from a user id to
    --   the string to use as the commenter's email.
    displayEmail :: AuthId m -> GHandler s m Text
    displayEmail _ = return ""

data Comment = Comment
    { threadId  :: ThreadId
    , commentId :: CommentId
    , timeStamp :: UTCTime
    , ipAddress :: Text
    , userName  :: Text
    , userEmail :: Text
    , content   :: Markdown
    , isAuth    :: Bool
    }

instance Eq Comment where
    a == b = (threadId a == threadId b) && (commentId a == commentId b)

data CommentForm = CommentForm
    { formUser    :: Text
    , formEmail   :: Text
    , formComment :: Markdown
    , formIsAuth  :: Bool
    }

type Form s m x = Html -> MForm s m (FormResult x, GWidget s m ())

commentFromForm :: YesodComments m => ThreadId -> CommentForm -> GHandler s m Comment
commentFromForm tid cf = do
    now <- liftIO getCurrentTime
    ip  <- fmap (show . remoteHost) waiRequest
    cid <- getNextCommentId tid

    return Comment 
        { threadId  = tid 
        , commentId = cid 
        , timeStamp = now
        , ipAddress = T.pack ip
        , userName  = formUser    cf
        , userEmail = formEmail   cf
        , content   = formComment cf
        , isAuth    = formIsAuth  cf
        }

commentForm :: RenderMessage m FormMessage => Form s m CommentForm
commentForm = renderBootstrap $ CommentForm
    <$> areq textField  "Name"  Nothing
    <*> areq emailField "Email" Nothing
    <*> areq markdownField commentLabel Nothing
    <*> pure False

commentFormAuth :: RenderMessage m FormMessage
                => Text -- ^ Text version of uid
                -> Text -- ^ user's email
                -> Form s m CommentForm
commentFormAuth user email = renderBootstrap $ CommentForm
    <$> pure user <*> pure email
    <*> areq markdownField commentLabel Nothing
    <*> pure True


handleForm :: YesodComments m => FormResult CommentForm -> ThreadId -> GWidget s m ()
handleForm (FormSuccess cf) tid = lift $ do
    storeComment =<< commentFromForm tid cf
    setMessage "comment added."
    redirectCurrentRoute

handleForm _ _ = return ()


showComment :: Comment -> GWidget s m ()
showComment comment = showHelper comment (userName comment, userEmail comment)

showCommentAuth :: (YesodAuth m, YesodComments m) => Comment -> GWidget s m ()
showCommentAuth comment = do
    let cusername = userName comment

    (cuname, cemail) <-
        if isAuth comment
            then case fromPathPiece $ cusername of
                Just uid -> do
                    uname <- lift $ displayUser  uid
                    email <- lift $ displayEmail uid
                    return (uname, email)
                _ -> return (cusername, userEmail comment)
            else return (cusername, userEmail comment)

    showHelper comment (cuname, cemail)

showComments :: [Comment] -> (Comment -> GWidget s m ()) -> GWidget s m ()
showComments comments f = [whamlet|
    <div .list>
        $if not $ null comments
            <h4>Showing #{toHtml $ helper $ length comments}:

            $forall comment <- comments
                ^{f comment}
    |]

    where
        -- pluralize comments
        helper :: Int -> String
        helper 0 = "no comments"
        helper 1 = "1 comment"
        helper n = show n ++ " comments"

showHelper :: Comment -> (Text,Text) -> GWidget s m ()
showHelper comment (username, email) = do
    commentTimestamp <- lift . liftIO . humanReadableTime $ timeStamp comment

    let anchor = "comment_" ++ show (commentId comment)

    [whamlet|
        <div .comment>
            <div .attribution>
                <p>
                    <span .avatar>
                        <img src="#{img email}">

                    <a href="##{anchor}" id="#{anchor}">#{commentTimestamp}
                    , #{username} wrote:

            <div .content>
                <blockquote>
                    #{markdownToHtml $ content comment}
        |]

    where
        img :: Text -> String
        img = gravatar defaultConfig { gDefault = Just MM, gSize = Just $ Size 20 }

-- | As the final step before insert, this is called to get the next
--   comment id for the thread. super-high concurrency is probably not
--   well-supported here.
getNextCommentId :: YesodComments m => ThreadId -> GHandler s m CommentId
getNextCommentId tid = go =<< loadComments (Just tid)

    where
        go :: YesodComments m => [Comment] -> GHandler s m CommentId
        go [] = return 1
        go cs = return $ maximum (map commentId cs) + 1

-- | Returns False when not logged in.
isCommentingUser :: YesodAuth m => Comment -> GHandler s m Bool
isCommentingUser comment = do
    muid <- maybeAuthId
    return $ case muid of
        Just uid -> isAuth comment && toPathPiece uid == userName comment
        _        -> False

-- | Redirect back to the current route after a POST request. Calls not
--   found if the current route is unknown.
redirectCurrentRoute :: Yesod m => GHandler s m ()
redirectCurrentRoute = do
    tm <- getRouteToMaster
    mr <- getCurrentRoute
    case mr of
        Just r  -> redirect $ tm r
        Nothing -> notFound

commentLabel ::  FieldSettings master
commentLabel = "Comment" { fsTooltip = Just "Comments are parsed as pandoc-style markdown." }