{-# Language TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}
{-# Language ExistentialQuantification, TupleSections #-}

----------------------------------------------------------------------------------------------------------------
module Anon.ImageBoard.Client.Web where
----------------------------------------------------------------------------------------------------------------
import Anon.Yesod
import Anon.Data.List
import Anon.Control.Monad.Trans.Either
----------------------------------------------------------------------------------------------------------------
import Yesod -- (mkYesod, parseRoutes, getYesod, defaultLayout, renderRoute, approot, warpDebug, yesodDispatch, RepHtml, Yesod, hamletToRepHtml, hamlet, FormMessage, defaultFormMessage)
import Yesod.Core
import Yesod.Widget
import Yesod.Static
----------------------------------------------------------------------------------------------------------------
import qualified Text.Blaze.Html5 as H
----------------------------------------------------------------------------------------------------------------
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.UUID as UUID
import qualified Data.Maybe as Maybe
import Control.Applicative ((<*>), (<$>))
import Control.Arrow
----------------------------------------------------------------------------------------------------------------
import Control.Monad.Trans.Control
import Control.Monad.Trans.Either
import Control.Monad.IO.Class
import Control.Monad
----------------------------------------------------------------------------------------------------------------
import qualified Anon.ImageBoard.Server.Data as Data

import qualified Anon.ImageBoard.TransferData.TryResult as TryResult
import qualified Anon.ImageBoard.TransferData.RemoteServerExceptionDetail as RemoteServerExceptionDetail
import qualified Anon.ImageBoard.TransferData.BoardPageRequest as BoardPageRequest
import qualified Anon.ImageBoard.TransferData.BoardRequest as BoardRequest
import qualified Anon.ImageBoard.TransferData.BoardPage as BoardPage
import qualified Anon.ImageBoard.TransferData.BoardGroup as BoardGroup
import qualified Anon.ImageBoard.TransferData.Board as Board
import qualified Anon.ImageBoard.TransferData.Thread as Thread
import qualified Anon.ImageBoard.TransferData.ThreadIdentity as ThreadIdentity
import qualified Anon.ImageBoard.TransferData.Post as Post
import qualified Anon.ImageBoard.TransferData.PostIdentity as PostIdentity
import qualified Anon.ImageBoard.TransferData.PostHeader as PostHeader
import qualified Anon.ImageBoard.TransferData.PostMessage as PostMessage
import qualified Anon.ImageBoard.TransferData.Attachment as Attachment
import qualified Anon.ImageBoard.TransferData.AttachmentFormatGroup as AttachmentFormatGroup
import qualified Anon.ImageBoard.TransferData.ImageAttachmentFormatGroup as ImageAttachmentFormatGroup
import qualified Anon.ImageBoard.TransferData.AttachmentFormat as AttachmentFormat
import qualified Anon.ImageBoard.TransferData.VideoAttachmentFormat as VideoAttachmentFormat
import qualified Anon.ImageBoard.TransferData.ImageSize as ImageSize
import qualified Anon.ImageBoard.TransferData.CaptchaRequestMode as CaptchaRequestMode

import qualified Anon.ImageBoard.Client.Web.CreatePostFill as CreatePostFill
----------------------------------------------------------------------------------------------------------------
--                                                                                                            --
----------------------------------------------------------------------------------------------------------------
data WebApplication = forall source. (Data.ServerDataStorage IO source) =>


                      WebApplicationData { boardGroups       :: [BoardGroup.BoardGroup]
                                         , dataSource        :: source
                                         , pageSize          :: Int
                                         , previewPostCount  :: Int
                                         , defaultSenderName :: String
                                         , cssFiles          :: Static
                                         , jsFiles           :: Static }
----------------------------------------------------------------------------------------------------------------
instance Yesod WebApplication

  where defaultLayout w = do p <- widgetToPageContent w
                             mmsg <- getMessage
                             hamletToRepHtml [hamlet|
!!!
<html>
    <head>
        <title>#{pageTitle p}
        ^{pageHead p}
        <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
        <link href="favicon.ico" rel="icon" type="image/png" />
    <body .Page>
        $maybe msg <- mmsg
            <p .message>#{msg}
        ^{pageBody p}
|]
----------------------------------------------------------------------------------------------------------------
instance RenderMessage WebApplication FormMessage where
    renderMessage _ _ = defaultFormMessage
----------------------------------------------------------------------------------------------------------------
--                                                                                                            --
----------------------------------------------------------------------------------------------------------------
mkYesod "WebApplication" [parseRoutesNoCheck|
/Content            SiteCss          Static cssFiles
/favicon.ico        FaviconR         GET

/                   MainPage         GET
/#String            DefaultBoardPage GET
/#String/#Int       BoardPage        GET
/#String/res/#Int   ThreadPage       GET

/CreatePost         CreatePost       POST

|]
----------------------------------------------------------------------------------------------------------------
--                                                                                                            --
----------------------------------------------------------------------------------------------------------------
getFaviconR :: Handler RepHtml
getFaviconR = sendFile "image/png" "static/favicon.ico"
----------------------------------------------------------------------------------------------------------------
rootTemplateLayout :: String -> Widget -> Handler RepHtml
rootTemplateLayout title widget = defaultLayout $ do addStylesheet $ SiteCss $ StaticRoute ["Site.css"] []
                                                     setTitle $ H.toHtml title
                                                     [whamlet|^{renderNavigationPanel}
                                                                <br>
                                                                ^{widget}|]
----------------------------------------------------------------------------------------------------------------
resultTemplateLayout :: (a -> String) -> (a -> Widget) -> TryResult.TryResult a -> Handler RepHtml
resultTemplateLayout _     _      (Left   error) = rootTemplateLayout "Error" [whamlet| Error: #{show error}|]
resultTemplateLayout getTitle render (Right result) = rootTemplateLayout (getTitle result) $ render result
----------------------------------------------------------------------------------------------------------------
renderNavigationPanel :: Widget
renderNavigationPanel = do app <- lift getYesod

                           sequence_ . List.intersperse [whamlet|&nbsp;-&nbsp;|]
                                     . map (brackets [whamlet|[|] [whamlet|]|] . sequence_
                                                                               . List.intersperse [whamlet|/|]
                                                                               . map (brackets [whamlet|&nbsp;|] [whamlet|&nbsp;|]))
                                     . links $ app

  where brackets open close value = open >> value >> close

        links :: WebApplication -> [[Widget]]
        links app = [[[whamlet|<strong>
                                <a href=@{DefaultBoardPage shortName}>#{shortName}|] | board <- visibleBoards
                                                                                     , let shortName = Board.shortName board]
                                                                                     | boardGroup <- boardGroups app
                                                                                     , let visibleBoards = BoardGroup.visibleBoards boardGroup
                                                                                     , visibleBoards /= []]
                 ++ [[[whamlet| <a href=@{MainPage}>Главная|]]]
----------------------------------------------------------------------------------------------------------------
renderBoardLogo :: Board.Board -> Widget
renderBoardLogo board = [whamlet|<div .BoardLogo>
                                    <a href=@{DefaultBoardPage shortName} .BoardLogoLink>#{fullName}|]

  where fullName  = Board.fullName  board
        shortName = Board.shortName board

----------------------------------------------------------------------------------------------------------------
getMainPage :: Handler RepHtml
getMainPage = rootTemplateLayout "Haskell ImageBoard. MainPage." [whamlet|Haskell ImageBoard|]
----------------------------------------------------------------------------------------------------------------
getThreadPage :: String -> Int -> Handler RepHtml
getThreadPage boardShortName threadLocalId = do app  <- getYesod
                                                info <- liftIO $ runEitherT $ getRenderInfo app

                                                resultTemplateLayout (Board.fullName . fst) renderThreadPage info

  where renderThreadPage :: (Board.Board, Thread.Thread) -> Widget
        renderThreadPage info @ (board, thread) = do (formWidget, formEnctype) <- lift $ generateFormPost $ createPostFillForm board $ Just localThreadId

                                                     [whamlet|
^{renderBoardLogo board}
<hr>
<a href=@{DefaultBoardPage shortName}>Вернуться
<div>
<form method=post action=@{CreatePost} enctype=#{formEnctype}>
    ^{formWidget}
<hr>
^{render info}
<hr>
|]

              where shortName = Board.shortName board

                    localThreadId = ThreadIdentity.localId $ Thread.threadId thread

        getRenderInfo :: WebApplication -> TryResult.TryResultT IO (Board.Board, Thread.Thread)
        getRenderInfo app = do board  <- EitherT $ return $ getBoardByShortCode boardShortName app
                               thread <- getRequest board `getThreadApp` app

                               return (board, thread)

        getRequest :: Board.Board -> ThreadIdentity.ThreadIdentity
        getRequest board = ThreadIdentity.ThreadIdentity { ThreadIdentity.boardId = Board.id board
                                                         , ThreadIdentity.localId = threadLocalId }
----------------------------------------------------------------------------------------------------------------
postCreatePost :: Handler RepHtml
postCreatePost = undefined
----------------------------------------------------------------------------------------------------------------
getDefaultBoardPage :: String -> Handler RepHtml
getDefaultBoardPage = getBoardPage `flip` 0
----------------------------------------------------------------------------------------------------------------
getBoardPage :: String -> Int -> Handler RepHtml
getBoardPage boardShortName pageIndex = do app  <- getYesod
                                           info <- liftIO $ runEitherT $ getRenderInfo app

                                           resultTemplateLayout (Board.fullName . fst) render info

  where getRenderInfo :: WebApplication -> TryResult.TryResultT IO (Board.Board, BoardPage.BoardPage)
        getRenderInfo app = do board     <- EitherT $ return $ getBoardByShortCode boardShortName app
                               boardPage <- getRequest app board `getBoardPageApp` app

                               return (board, boardPage)


        getRequest :: WebApplication -> Board.Board -> BoardPageRequest.BoardPageRequest
        getRequest app board = BoardPageRequest.BoardPageRequest { BoardPageRequest.boardId          = Board.id board
                                                                 , BoardPageRequest.threadStartIndex = pageIndex * pageSize app
                                                                 , BoardPageRequest.threadCount      = pageSize app
                                                                 , BoardPageRequest.previewPostCount = previewPostCount app }
----------------------------------------------------------------------------------------------------------------
getBoardByShortCode :: String -> WebApplication -> TryResult.TryResult Board.Board
getBoardByShortCode boardShortName = getBoardByShortCode' . List.find ((== boardShortName) . Board.shortName) . concatMap BoardGroup.boards . boardGroups

  where getBoardByShortCode' (Just board) = Right $ board
        getBoardByShortCode' Nothing      = TryResult.boardByShortNameNotFound boardShortName
------------------------------------------------------------------------------------------------------------------------------------
class Renderable a

  where render :: a -> Widget
------------------------------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, BoardPage.BoardPage)

  where render (board, boardPage) = do (formWidget, formEnctype) <- lift $ generateFormPost $ createPostFillForm board Nothing
                                       [whamlet|
^{renderBoardLogo board}
<hr>
<form method=post action=@{CreatePost} enctype=#{formEnctype}>
    ^{formWidget}
$forall thread <- BoardPage.selectedThreads boardPage
  <hr>
  ^{renderThread thread}
<hr>
|]

          where renderThread = render . (board,)
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, Thread.Thread)

  where render (board, thread @ Thread.Thread { Thread.threadId     = threadId
                                              , Thread.posts        = (mainPost : bodyPosts)
                                              , Thread.collapseInfo = collapseInfo }) = [whamlet|

<div>
  ^{renderPost mainPost}
  $forall bodyPost <- bodyPosts
    <br>
    ^{renderPost bodyPost } |]

          where renderPost = render . (board, thread,)
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, PostIdentity.PostIdentity)

  where render (board, PostIdentity.PostIdentity { PostIdentity.localId  = postLocalId
                                                 , PostIdentity.threadId = threadId } ) = [whamlet|

<a onclick=addComment (this.href) href=@{ThreadPage boardShortName $ ThreadIdentity.localId threadId}#{fragment}>
    №#{postLocalId} |]

          where boardShortName = Board.shortName board

                fragment = "#i" ++ show postLocalId
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, Thread.Thread, PostHeader.PostHeader)

  where render (board, thread, postHeader) = do app <- lift getYesod
                                                [whamlet|
<a name=#{PostIdentity.localId postId}>
<label>
    <input type=checkbox name=deletepost onclick=deletePost(this) value=#{PostIdentity.localId postId}>
    &nbsp;
    <span .Subject>
        #{PostHeader.subject postHeader}
    &nbsp;
    <span>
        $if PostHeader.isSage postHeader
            <a href=mailto:sage>
                #{sender app}
        $else
            #{sender app}
    &nbsp;
    #{show $ PostHeader.createDate postHeader}
&nbsp;
<span .RefLink>
    ^{renderPostLink}|]

          where sender app = defaultSenderName app `fromList` PostHeader.sender postHeader

                postId = PostHeader.postId postHeader

                renderPostLink = render (board, postId)
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, Thread.Thread, PostMessage.PostMessage)

  where render (board, thread, message) = [whamlet|message|]
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, Thread.Thread, Attachment.Attachment)

  where render (board, thread, attachment) = [whamlet|attachment|]
----------------------------------------------------------------------------------------------------------------
instance Renderable (Board.Board, Thread.Thread, Post.Post)

  where render (board, thread, Post.Post { Post.header     = header
                                         , Post.message    = maybeMessage
                                         , Post.attachment = maybeAttachment })

          | PostIdentity.isMainPost postId  = [whamlet|
<div #id=#{PostIdentity.localId postId}>
    ^{maybeRender renderItem maybeAttachment}
    ^{renderItem header}
    <div>
        ^{ maybeRender renderItem maybeMessage} |]

          | otherwise                       = [whamlet|
<table>
    <tbody>
        <tr>
            <td>
                ^{renderItem header}
                <br>
                ^{maybeRender renderItem maybeAttachment}
                ^{maybeRender renderItem maybeMessage} |]

          where postId = PostHeader.postId header

                renderItem :: Renderable (Board.Board, Thread.Thread, a) => a -> Widget
                renderItem item = render (board, thread, item)
----------------------------------------------------------------------------------------------------------------
--                                                                                                            --
----------------------------------------------------------------------------------------------------------------
createPostFillForm :: Board.Board -> Maybe Int -> Html -> MForm WebApplication WebApplication (FormResult CreatePostFill.CreatePostFill, Widget)
createPostFillForm board tryThreadLocalId extra =

  do (goToThreadRes, goToThreadView) <- mreq checkBoxField "Go To Thread" Nothing
     (boardIdRes, boardIdView) <- mreq hiddenField ("Board Id" { fsId = Just "BoardId", fsName = Just "BoardId" }) $ Just $ Board.id board
     (threadLocalIdRes, threadLocalIdView) <- mopt hiddenField ("Thread Local Id" { fsId = Just "ThreadLocalId", fsName = Just "ThreadLocalId" }) $ Just $ tryThreadLocalId
     (captchaKeyRes, captchaKeyView) <- mreq hiddenField ("Captcha Key" { fsId = Just "CaptchaKey", fsName = Just "CaptchaKey" } ) $ Nothing
     (isSageRes, isSageView) <- mreq checkBoxField "Sage" Nothing

     (subjectRes, subjectView) <- mopt textField "Subject" Nothing
     (senderRes, senderView) <- mopt textField "Sender" Nothing
     (passwordRes, passwordView) <- mopt textField "Password" Nothing
     (captchaSolutionRes, captchaSolutionView) <- mopt textField "Captcha Solution" Nothing
     (postMessageRes, postMessageView) <- mopt textareaField (addTextAreaSize 60 6 $ "Post Message" { fsId = Just "PostMessage", fsName = Just "PostMessage" } ) Nothing
     (noFileRes, noFileView) <- mreq checkBoxField ("No File"{ fsId = Just "NoFile", fsName = Just "NoFile" } ) Nothing
     (attachmentRes, attachmentView) <- moptFileInfoField "Attachment"
     (externalVideoAttachmentRes, externalVideoAttachmentView) <- mopt textField "External Video Attachment" Nothing

     let createPostFillRes = CreatePostFill.CreatePostFill <$> goToThreadRes
                                                           <*> boardIdRes
                                                           <*> threadLocalIdRes
                                                           <*> (read <$> captchaKeyRes)
                                                           <*> isSageRes
                                                           <&> subjectRes
                                                           <&> senderRes
                                                           <&> passwordRes
                                                           <&> captchaSolutionRes
                                                           <@> postMessageRes
                                                           <*> noFileRes
                                                           <*> attachmentRes
                                                           <&> externalVideoAttachmentRes



     let widget = [whamlet|
#{extra}
^{fvInput boardIdView}
^{fvInput threadLocalIdView}
<div .CreatePostHeader>
    #{createPostHeaderMessage}
<table .CreatePostTable>
    <tbody>
        <tr>
            <td>
                Имя
            <td>
                ^{fvInput senderView}
                <em>
                    (оставьте это поле пустым)
        <tr>
            <td>
                Sage
            <td>
                ^{fvInput isSageView}
                <em>
                    (не поднимать этот ITT тред)
        <tr>
            <td>
                Тема
            <td>
                ^{fvInput subjectView}
                <input type="submit" value="Отправить" />
        <tr>
            <td>
                Мнение
                <br> анонимного
                <br> иксперта
            <td>
                ^{fvInput postMessageView}
        <tr>
            <td>
                Файл
            <td>
                ^{fvInput attachmentView}
                [^{fvInput noFileView}
                <label for="NoFile">Без файла]

        $if hasVideoGroupFormats
             <tr>
                <td>
                    Видео
                    <td>
                        ^{fvInput externalVideoAttachmentView}

        <tr>
            <td>
                К треду
            <td>
                ^{fvInput goToThreadView}
        $if hasCaptcha
            <tr>
                <td>
                    Капча
                    <td>
                        <img alt="(капча появится по клику)" id="CaptchaImage" style="cursor:pointer" />
                        ^{fvInput captchaKeyView}
                <tr>
                    <td>
                        Подтверждение
                    <td>
                        ^{fvInput captchaSolutionView}

        <tr>
            <td>
                Пароль
            <td>
                ^{fvInput passwordView}
                (чтобы удалить пост или файл)
        $if not $ Text.null allowedAttachmentFormats
            <tr>
                <td colspan="2">
                    <ul>
                        <li>
                            Поддерживаемые типы файлов: #{allowedAttachmentFormats}

                        <li>
                            Максимальный размер файла #{maxAttachmentSizeKB} KB.

                        $if not $ Text.null allowedAttachmentFormats
                            <li>
                                Изображения больше #{maxImageAttachmentSize} будут уменьшены.

|]
     return (createPostFillRes, widget)

  where maxAttachmentSizeKB :: Int
        maxAttachmentSizeKB = Board.maxAttachmentSize board `div` 1024

        maxImageAttachmentSize :: Text.Text
        maxImageAttachmentSize = Text.pack $ concat
                               $ [ show (ImageSize.width maxCanvasSize) ++ "x" ++ show (ImageSize.height maxCanvasSize)
                                 | (AttachmentFormatGroup.ImageAttachmentFormatGroup' (ImageAttachmentFormatGroup.ImageAttachmentFormatGroup { ImageAttachmentFormatGroup.maxCanvasSize = maxCanvasSize })) <- Board.attachmentFormatGroups board]


        allowedAttachmentFormats :: Text.Text
        allowedAttachmentFormats = Text.toUpper $ Text.pack $ concat $ List.intersperse ", "
                                 $ [ show $ AttachmentFormat.code format | attachmentFormatGroup <- Board.attachmentFormatGroups board
                                                                         , not $ AttachmentFormatGroup.isExternal attachmentFormatGroup
                                                                         , format <- AttachmentFormatGroup.formats attachmentFormatGroup]

        hasCaptcha :: Bool
        hasCaptcha = Board.hasCaptcha board captchaRequestMode


        captchaRequestMode :: CaptchaRequestMode.CaptchaRequestMode
        captchaRequestMode | isThreadMode = CaptchaRequestMode.CreatePost
                           | otherwise    = CaptchaRequestMode.CreateThread

        hasVideoGroupFormats :: Bool --[VideoAttachmentFormat.VideoAttachmentFormat]
        hasVideoGroupFormats = not $ null $ Board.videoGroupFormats board

        isThreadMode :: Bool
        isThreadMode = tryThreadLocalId /= Nothing

        createPostHeaderMessage :: Text.Text
        createPostHeaderMessage | isThreadMode = "Ответить в тред"
                                | otherwise    = "Создать новый тред"

----------------------------------------------------------------------------------------------------------------
getThreadApp threadIdentity (WebApplicationData { dataSource = dataSource }) = liftIOEitherT $ Data.getThread threadIdentity dataSource
----------------------------------------------------------------------------------------------------------------
getBoardPageApp boardPageRequest (WebApplicationData { dataSource = dataSource }) = liftIOEitherT $ Data.getBoardPage boardPageRequest dataSource
----------------------------------------------------------------------------------------------------------------