{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Pages.Board where

import ConfigT
import Control.Applicative
import Control.Applicative.Error
import Control.Monad
import Control.Monad.Trans
import           Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Data.Acid hiding (update, query)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List
import           Happstack.Data.IxSet ((@=))
import qualified Happstack.Data.IxSet as IxSet
import Happstack.Server
import HJScript.DOM (Node, alert, document, window)
import HJScript.Utils ()
import HJScript hiding ((<|>))
import HJScript.Objects.JQuery hiding (submit)
import HSP
import qualified HSX.XMLGenerator as HSX
import Pages.AppTemplate
import Server
import State
import System.Locale
import Text.Formlets (Form, File(fileName, content), Rect(..), check, checkM, plug, xml)
import HSP.Formlets (checkboxes, input, label, submit, file, password, submit, textarea)
import Happstack.Server.Formlets (formletPart, handleFailure)
import Types
import URL
import Web.Routes

boardPage :: WebURL -> BoardName -> (Maybe Int) -> Server Response
boardPage here boardName mPage =
    do res <- query (GetThreads (fromMaybe 0 mPage) boardName)
       case res of
         (Left e) -> error (show e)
         (Right (threads, maxPageNum)) -> 
             do let media = mapMaybe medium (concatMap posts threads)
                mediaJS <- imageToggles media
                let script = embedScript (ready' mediaJS)
                toResponse <$> (unXMLGenT $ boardTemplate here (Right (boardName, maxPageNum)) (Text.unpack (unBoardName boardName)) script <% mapM threadHTML threads %>)

boardTemplate :: 
    ( EmbedAsChild Server headers
    , EmbedAsChild Server body
    ) =>
       WebURL 
    -> (Either ThreadId (BoardName, Int))
    -> String -- ^ title 
    -> headers  -- ^ extra tags to include in \<head\>
    -> body    -- ^ contents to put inside \<body\> 
    -> XMLGenT Server XML
boardTemplate here@(W_Board _ mPage) postType title headers body =
    do config <- askConfig
       login <- case role config of
                  User -> 
                      do loginURL <- showURL (W_Login here)
                         <span class="admin"><a href=loginURL>login</a></span>
                  Moderator -> 
                      do moderatorURL <- showURL W_Moderator
                         <span class="admin"><a href=moderatorURL>moderator</a></span>
                  Admin ->
                      do adminURL <- showURL W_Admin
                         <span class="admin"><a href=adminURL>admin</a></span>
       hereURL <- showURL here
       bds <- query AskBoards
       appTemplate title headers 
         <div>
          <% login %>
          <% boardLinks bds %>
          <% boardTitle bds %>
          <div class="replyform">
           <% formletPart hereURL handleSuccess handleFailure' (postFormlet `checkM` (validateNewThread config)) %>
          </div>
          <% body %>
          <% pageNavigator %>
         </div>
    where
      boardLinks bds =
          do links <- mapM boardLink (IxSet.toList bds)
             <span>[ <% intersperse (pcdata " / ") $ links %> ]</span>
      boardLink board =
          do l <- showURL (W_Board (BoardName (name board)) Nothing)
             <a href=l><% Text.unpack (abbrev board) %></a>
      boardTitle bds =
          case postType of
            (Left threadId) ->
                <h1>Reply Mode</h1>
            (Right (boardName, _)) ->
                case IxSet.getOne (bds @= boardName) of
                     Nothing ->      <h1><% Text.unpack (unBoardName boardName) %></h1>
                     (Just board) -> <h1>/<% Text.unpack $ abbrev board %>/ - <% Text.unpack $ name board %></h1> 
      pageNavigator =
          case postType of
            (Left _) -> return (pcdata "")
            (Right (boardName, maxPageNum)) ->
                do let currentPage = fromMaybe 0 mPage
                   pageURLs <- mapM (\n -> showURL (W_Board boardName (Just n))) [0..maxPageNum]
                   <div class="pagelinks">
                    <p>Goto page:</p>
                    <ul><% mapM (\(n, url) -> 
                                                      if (n == currentPage)
                                                      then <li class="current">[<a href=url><% show n %></a>]</li>
                                                      else <li>[<a href=url><% show n %></a>]</li>
                                                 ) (zip [0..maxPageNum] pageURLs) %>
                    </ul>
                    </div>

      handleSuccess c@(name, tripcode, subject, medium, msg) =
          case postType of
            (Right (boardName, _)) ->
                do now <- liftIO $ getCurrentTime
                   res <- update (NewThread now boardName name tripcode subject medium msg)
                   case res of
                     (Left (InvalidBoardName (BoardName bn))) ->
                         do maybe (return True) expireMedium medium
                            internalServerError =<< (appTemplate "Internal Error" () <div>Internal Error: Invalid Board Name: <% Text.unpack bn %></div>)
                     (Right _thread) ->
                            seeOtherURL here
            (Left threadId) ->
                do now <- liftIO $ getCurrentTime
                   res <- update (ReplyThread now threadId name tripcode subject medium msg)
                   case res of
                     (Left InvalidId) ->
                         notFound =<< appTemplate "404 Not Found" () <p>The thread you are trying to reply to does not exist.</p>
                     (Right post) ->
                         do seeOtherURL here
      handleFailure' errs frmXML = handleFailure (\t b -> appTemplate t () b) errs frmXML

validateNewThread :: (MonadIO m) => Config -> (String, String, String, File, String) -> m (Failing (Maybe Text, Maybe String, Maybe Text, Maybe Medium, Text))
validateNewThread config (name, tripCode, subject, file, msg) =
    if (B.null (content file) ||  null msg)
       then return $ Failure ["You must supply and image and a comment to start a new thread."]
       else do medium <- saveImage (acid config) (storageDir config) (fileName file) (C.unpack $ content file)
               return $ Success $ (maybeText name, maybeString tripCode, maybeText subject, Just medium, Text.pack msg)
    where
      maybeString  :: String -> Maybe String
      maybeString [] = Nothing
      maybeString str = Just str
      maybeText  :: String -> Maybe Text
      maybeText = fmap Text.pack . maybeString


threadHTML :: (XMLGenerator m, ShowURL m, URL m ~ WebURL, EmbedAsChild m ()) => Thread -> XMLGenT m (HSX.XML m)
threadHTML thread =
    do replyURL <- showURL (W_Reply (threadId thread))
       <div class="thread">
          <% case (posts thread) of
               [] -> <p>Odd. This thread does not contain any posts.</p>
               (h:t) ->
                   <ul>
                     <% sequence $ (postHTML True h) : (map (postHTML False) t) %>
                   </ul>
           %> 
         <p>[ <a href=replyURL>Reply</a> ]</p>
        </div>

-- unpacking Text to String and then later converting it to a ByteString seems wrong. We should go straight to BS perhaps? Though, maybe not.
postHTML :: (XMLGenerator m, EmbedAsChild m (), ShowURL m, URL m ~ WebURL) => Bool -> Post -> XMLGenT m (HSX.XML m)
postHTML first post = do 
    <li class=(if first then "first post" else "reply post")>
      <p><span class="postername"><% maybe "Anonymous" Text.unpack (poster post) %></span> <span class="tripcode"><% maybe "" Text.unpack (subject post) %></span> <% formatTime defaultTimeLocale rfc822DateFormat (posted post) %> <span class="postid">No.<% show $ unPostId $ postId post %></span></p>
      <% case medium post of
           Nothing -> <% () %>
           (Just medium) -> <% <div class="medium"><% mediumHTML medium %></div> %>
       %>
      <p><% Text.unpack (msg post) %></p>
     </li>

mediumHTML :: (ShowURL m, XMLGenerator m, URL m ~ WebURL) => Medium -> XMLGenT m (HSX.XML m)
mediumHTML img@(Image {}) =
    do imgThumbnailURL <- showURL (W_Image (mediumId img) Thumbnail (uploadName img))
       imgURL <- showURL (W_Image (mediumId img) FullSize  (uploadName img))
       <a href=imgURL><img id=("medium_" ++ show (unMediumId (mediumId img))) src=imgThumbnailURL alt="" /></a> 

postFormlet :: (XMLGenerator x, Applicative v, Monad v) => Form [XMLGenT x (HSX.XML x)] v (String, String, String, File, String)
postFormlet =
    (,,,,) <$>
      (label "Name" *> input Nothing <* br ) <*>
      (label "Password" *> password Nothing <* span "(optional)" <* br) <*>
      (label "Subject" *> input Nothing <* br) <*>
      (label "Image" *> file <* br) <*>
      (textarea (const (Rect 60 8)) Nothing <* br) <*
      (submit "Post")
    where
      br = xml [<br />]
      span c =  xml [<span><% c %></span>]

imageToggleJS :: (WebURL ~ URL m, ShowURL m, Monad m) => Medium -> m (HJScript (Exp JQuery))
imageToggleJS img@Image{} =
    do fullURL      <- showURL (W_Image (mediumId img) FullSize (storedName img))
       thumbnailURL <- showURL (W_Image (mediumId img) Thumbnail ("t_" ++ storedName img))
       return $ itjs (mediumId img) fullURL thumbnailURL

jSetAttr :: (JString, JString) -> JObject JQuery -> JObject JQuery
jSetAttr = methodCall "attr"

toggle2 :: (Exp (() -> ()), Exp (() -> ())) -> Exp JQuery -> Exp JQuery
toggle2 = callMethod "toggle"


itjs :: MediumId -> String -> String -> HJScript (Exp JQuery)
itjs mediumId fullURL thumbnailURL = 
    do full  <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string fullURL)
       thumb <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string thumbnailURL)
       return $ selectExpr (string $ "#medium_" ++ show (unMediumId mediumId)) # toggle2 (full, thumb)

imageToggles :: (WebURL ~ URL m, ShowURL m, Monad m) => [Medium] -> m (HJScript ())
imageToggles media =
    do js <- mapM imageToggleJS media
       return $ mapM_ (runExp =<<) js

ready' :: HJScript () -> HJScript ()
ready' script
    = do fn <- procedure $ \() -> script
         runExp $ selectExpr document # readyFn fn

readyFn :: Exp (() -> ()) -> JObject JQuery -> Exp ()
readyFn = methodCall "ready"