{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell,
             TypeFamilies, TypeSynonymInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -F -pgmFhsx2hs #-}
module TinyAuth.Pages where

import Data.Text (Text)
import qualified Data.Text as Text (null, unpack)
import qualified Data.Text.Lazy as Lazy (pack, Text)
import Data.Time.Clock (getCurrentTime)
import HSP (toName)
import HSP.XML as HTML (Attribute(MkAttr), pAttrVal, XML(CDATA))
import Happstack.Auth (AuthProfileURL, getUserId, handleAuthProfile)
import Happstack.Foundation ((++>), (<$>), (<++), Applicative((<*), (<*>)), asContentType, Attr(..), EmbedAsAttr(..), EmbedAsChild(..), errorList, fieldset, form, fromStringLit, Functor, Happstack, inputSubmit, inputText, label, li, liftM, mapM, method, Method(GET), Monad(return), MonadIO(liftIO), nestURL, notFound, ok, PathInfo(toPathSegments), query, reform, Response, RouteT, seeOtherURL, select, serveFile, showURL, textarea, ToMessage(toResponse), transformEither, transformEitherM, ul, update, whereami, XML, XMLGen(..), XMLGenerator, XMLGenT(XMLGenT))
import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import TinyAuth.Acid (Acid(..))
import TinyAuth.Events (GetPasteById(GetPasteById), GetRecentPastes(GetRecentPastes), InsertPaste(InsertPaste))
import TinyAuth.Route (CtrlV, CtrlVForm, Route(..))
import TinyAuth.Template (appTemplate, baseAppTemplate)
import TinyAuth.Types (Format(..), Paste(..), PasteId(..), PasteMeta(PasteMeta, format, nickname, pasteId, pasted, title))

------------------------------------------------------------------------------
-- Pages
------------------------------------------------------------------------------

-- | page handler for 'ViewRecent'
viewRecentPage :: Acid -> CtrlV Response
viewRecentPage acid =
    do method GET
       recent <- query (GetRecentPastes 20 0)
       case recent of
         [] -> appTemplate acid "Recent Pastes" () <p>There are no pastes yet.</p>
         _  -> appTemplate acid "Recent Pastes" () $
                <%>
                 <h1>Recent Pastes</h1>
                 <table>
                  <thead>
                   <tr>
                    <th>id</th>
                    <th>title</th>
                    <th>author</th>
                    <th>date</th>
                    <th>format</th>
                   </tr>
                  </thead>
                  <tbody>
                   <% mapM mkTableRow recent %>
                  </tbody>
                 </table>
                </%>
    where
      mkTableRow PasteMeta{..} =
          <tr>
           <td><a href=(ViewPaste pasteId)><% show $ unPasteId pasteId %></a></td>
           <td><a href=(ViewPaste pasteId)><% title       %></a></td>
           <td><% nickname    %></td>
           <td><% pasted      %></td>
           <td><% show format %></td>
          </tr>

-- | page handler for 'ViewPaste'
viewPastePage :: Acid -> PasteId -> CtrlV Response
viewPastePage acid pid =
    do method GET
       mPaste <- query (GetPasteById pid)
       case mPaste of
         Nothing ->
             do notFound ()
                appTemplate acid "Paste not found." () $
                    <p>Paste <% pid %> could not be found.</p>
         (Just (Paste (PasteMeta{..}) paste)) ->
             do ok ()
                appTemplate acid (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $
                    <div class="paste">
                     <dl class="paste-header">
                      <dt>Paste:</dt><dd><a href=(ViewPaste pid)><% pid %></a></dd>
                      <dt>Title:</dt><dd><% title %></dd>
                      <dt>Author:</dt><dd><% nickname %></dd>
                     </dl>
                     <div class="paste-body">
                      <% formatPaste format paste %>
                     </div>
                    </div>

-- | convert the paste to HTML. We currently only support 'PlainText',
-- but eventually it might do syntax hightlighting, markdown, etc.
--
-- Note that we do not have to worry about escaping the txt
-- value.. that is done automatically by HSP.
formatPaste :: Format -> Text -> CtrlV XML
formatPaste PlainText txt =
    <pre><% txt %></pre>

-- | page handler for 'NewPaste'
newPastePage :: Acid -> CtrlV Response
newPastePage acid@Acid{..} =
    do here <- whereami
       mUserId <- getUserId acidAuth acidProfile
       case mUserId of
          Nothing ->
            appTemplate acid "Add a Paste" () $
              <%>
                <h1>You Are Not Logged In</h1>
              </%>
          (Just uid) ->
            appTemplate acid "Add a Paste" () $
              <%>
                <h1>Add a paste</h1>
                <% reform (form here) "add" success Nothing pasteForm %>
              </%>
    where
      success :: Paste -> CtrlV Response
      success paste =
          do pid <- update (InsertPaste paste)
             seeOtherURL (ViewPaste pid)

-- | the 'Form' used for entering a new paste
pasteForm :: CtrlVForm Paste
pasteForm =
    (fieldset $
       ul $
          (,,,) <$> (li $ label <span>title</span>  ++> (inputText "" `transformEither` required) <++ errorList)
                <*> (li $ label <span>nick</span>   ++> (inputText "" `transformEither` required) <++ errorList)
                <*> (li $ label <span>format</span> ++> formatForm)
                <*> (li $ label <div>paste</div>    ++> errorList ++> (textarea 80 25 "" `transformEither` required))
                <* inputSubmit "paste!"
    )  `transformEitherM` toPaste
    where
      formatForm =
          select [(a, show a) | a <- [minBound .. maxBound]] (== PlainText)
      toPaste (ttl, nick, fmt, bdy) =
          do now <- liftIO getCurrentTime
             return $ Right $
                        (Paste { pasteMeta = PasteMeta { pasteId  = PasteId 0
                                                       , title    = ttl
                                                       , nickname = nick
                                                       , format   = fmt
                                                       , pasted   = now
                                                       }
                               , paste = bdy
                               })
      required txt
          | Text.null txt = Left "Required"
          | otherwise     = Right txt

------------------------------------------------------------------------------
-- Auth Support Functions
------------------------------------------------------------------------------

-- the key to using happstack-authenticate with HSP is simple. First
-- you need to be able to embed Html in your HSP monad like this:
--
-- I (Robin Lee Powell) don't know how to fix this warning:
--
--    Warning: orphan instance:
--      instance (Functor m, Monad m) => EmbedAsChild (RouteT url m) Html
--
instance (Functor m, Monad m) => EmbedAsChild (RouteT url m) Html where
    asChild html = asChild (HTML.CDATA False (renderHtml html))

-- If you want to use your usual app template, then the auth stuff,
-- which is in RouteT AuthProfileURL, needs to have a way to render
-- your routes inside that context.
--
instance (Functor m, Monad m) => EmbedAsAttr (RouteT AuthProfileURL m) (Attr Lazy.Text Route) where
    asAttr (n := u) = do
           asAttr $ MkAttr (toName n, pAttrVal (Lazy.pack $ concatMap (((++) "/") . Text.unpack) (toPathSegments u)))

-- Stick our usual app template into a state where the auth
-- functions, which are Blaze based, are OK with it.
appTemplate' :: (Happstack m, EmbedAsAttr m (Attr Lazy.Text Route), XMLGenerator m, EmbedAsChild m Html, StringType m ~ Lazy.Text, XMLType m ~ XML) => Acid -> Lazy.Text -> Html -> Html -> m Response
appTemplate' a t h b = liftM toResponse (baseAppTemplate a t h b)

------------------------------------------------------------------------------
-- route
------------------------------------------------------------------------------

-- | the route mapping function
route :: Acid -> Text -> Route -> CtrlV Response
route acid@Acid{..} baseURL url =
    case url of
      -- FIXME: replace the ViewRecent thing here with "go back to
      -- the last page we were on". - rlpowell
      (U_AuthProfile authProfileURL) ->
          do vr <- showURL ViewRecent
             XMLGenT $ nestURL U_AuthProfile $ handleAuthProfile acidAuth acidProfile (\s -> appTemplate' acid (Lazy.pack s)) Nothing (Just baseURL) vr authProfileURL
      ViewRecent      -> viewRecentPage acid
      (ViewPaste pid) -> viewPastePage acid pid
      NewPaste        -> newPastePage acid
      CSS             -> serveFile (asContentType "text/css") "style.css"