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

import Acid
import ConfigT
import Control.Applicative
import Control.Applicative.Error
import Control.Monad
import Control.Monad.Trans
import Data.Function
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           Data.IxSet ((@=))
import qualified Data.IxSet as IxSet
import Happstack.Server
import Happstack.Server.HSP.HTML
import HSP
import qualified HSX.XMLGenerator as HSX
import HSX.JMacro
import Language.Javascript.JMacro
import Pages.AppTemplate
import Pages.FormPart
import Server
import State
import System.Locale
import Text.Digestive
import Text.Digestive.HSP.Html4
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)
       env <- askRqEnv
       liftIO $ print env
       case res of
         (Left e) -> error (show e)
         (Right (threads, maxPageNum)) -> 
             do let media = mapMaybe medium (concatMap posts threads)
                script <- genOnReady media
                toResponse <$> (unXMLGenT $ boardTemplate here mPage (Right (boardName, maxPageNum)) (Text.unpack (unBoardName boardName)) script <% mapM threadHTML threads %>)

boardTemplate :: 
    ( EmbedAsChild Server headers
    , EmbedAsChild Server body
    ) =>
       WebURL 
    -> Maybe Int
    -> (Either ThreadId (BoardName, Int))
    -> String -- ^ title 
    -> headers  -- ^ extra tags to include in \<head\>
    -> body    -- ^ contents to put inside \<body\> 
    -> XMLGenT Server XML
boardTemplate here 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
       bdLnks <- boardLinks bds
       appTemplate title headers 
         <div>
          <% login %>
          <% bdLnks %>
          <% boardTitle bds %>
          <div class="replyform">
           <% formPart "post" hereURL handleSuccess Nothing (postFormlet `transform` (validateNewThread config (either (const True) (const False) postType))) %>
          </div>
          <% body %>
          <% pageNavigator %>
          <% bdLnks %>
         </div>
    where
      boardLinks bds =
          do links <- mapM boardLink $ sortBy (compare `on` abbrev) $ (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 :: (Maybe Text, Maybe Password, Maybe Text, Maybe Medium, Text) -> Server XML
      handleSuccess c@(name, tripcode, subject, medium, msg) =
         unXMLGenT $
          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) ->
                         do notFound  ()
                            appTemplate "404 Not Found" () <p>The thread you are trying to reply to does not exist.</p>
                     (Right post) ->
                         do seeOtherURL here

validateNewThread :: Config -> Bool -> Transformer Server String (Text, Maybe Password, Text, Maybe (FilePath, FilePath), String) (Maybe Text, Maybe Password, Maybe Text, Maybe Medium, Text)
validateNewThread config replyMode =
    transformEitherM $ \(name, tripCode, subject, mFile, msg) ->
        case (null msg, replyMode, mFile) of
          (True,  True,  _)        -> return $ Left "You must supply a comment to respond to a thread."
          (True,  False, _)        -> return $ Left "You must supply and image and a comment to start a new thread."
          (False, False, Nothing)  -> return $ Left "You must supply and image and a comment to start a new thread."
          (False,     _, Just (origName, tmpFile))
              | origName == "" && (not replyMode) -> return $ Left "You must supply and image and a comment to start a new thread."
              | origName == "" && replyMode -> 
                  do return  $ Right $ (maybeText name, tripCode, maybeText subject, Nothing, Text.pack msg)
              | otherwise -> 
                  do medium <- saveImage (acidBoard $ acid config) (storageDir config) origName tmpFile
                     return $ Right $ (maybeText name, tripCode, maybeText subject, Just medium, Text.pack msg)
    where
      maybeText  :: Text -> Maybe Text
      maybeText t =
          if Text.null t 
             then Nothing
             else (Just t)

threadHTML :: (XMLGenerator m, MonadRoute m, URL m ~ WebURL, EmbedAsChild m (), EmbedAsAttr m (Attr String Text)) => 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>

-- TODO: add tripcode
postHTML :: (XMLGenerator m, EmbedAsChild m (), EmbedAsAttr m (Attr String Text), MonadRoute 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 :: (MonadRoute m, XMLGenerator m, EmbedAsAttr m (Attr String Text), 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 :: ServerForm (Text, Maybe Password, Text, Maybe (FilePath, FilePath), String)
postFormlet =
    errors ++>
    ((,,,,) <$>
      (label "Name"     ++> inputText Nothing <* br ) <*>
      (label "Password" ++> (inputPassword `transform` toPassword) <* span "(optional)" <* br) <*>
      (label "Subject"  ++> inputText Nothing <* br) <*>
      (label "Image"    ++> inputFile <* br) <*>
      (inputTextArea (Just 60) (Just 8) Nothing <* br) <*
      (submit "Post"))
    where
      br     = view [<br />]
      span c =  view [<span><% c %></span>]
      toPassword =
          transformEitherM $ \str ->
              if null str
                 then return (Right Nothing)
                 else do p <- liftIO $ makePassword (Text.pack str)
                         return (Right (Just p))

onReady :: [(String, String, String)] -> JStat
onReady images =
    [$jmacro|
      fun makeToggle id full thumbnail {
                $(id).toggle( function () { $(this).attr('src', full) }
                            , function () { $(this).attr('src', thumbnail) }
                            );
      }
      $(document).ready ( 
        function () {
          var imgs = `(images)`;
          for (var i = 0; i < imgs.length; i++) {
                    makeToggle(imgs[i][0],imgs[i][1],imgs[i][2]);
                  }
        } 
       );
    |]

genOnReady :: [Medium] -> Server JStat
genOnReady mediums =
    do fullURL      <- mapM (\img -> Text.unpack <$> showURL (W_Image (mediumId img) FullSize (storedName img))) mediums
       thumbnailURL <- mapM (\img -> Text.unpack <$> showURL (W_Image (mediumId img) Thumbnail ("t_" ++ storedName img))) mediums
       let ids = map (\m -> "#medium_" ++ show (unMediumId (mediumId m))) mediums
       return $ onReady $ zipWith3 (,,) ids fullURL thumbnailURL