{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell,
             TypeFamilies, TypeSynonymInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -F -pgmFhsx2hs #-}
module Tiny.PagesAuth
    ( route
    ) 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, AuthState, ProfileState)
import Happstack.Foundation ((++>), (<$>), (<++), Applicative((<*), (<*>)), asContentType, Attr(..), EmbedAsAttr(..), EmbedAsChild(..), errorList, fieldset, form, fromStringLit, Happstack, inputSubmit, inputText, label, li, liftM, method, Method(GET), MonadIO(liftIO), nestURL, notFound, ok, PathInfo(toPathSegments), query, reform, Response, RouteT, seeOtherURL, select, serveFile, showURL, textarea, ToMessage(toResponse), transformEither, transformEitherM, ul, update, whereami, XMLGen(..), XMLGenerator, XMLGenT(XMLGenT), AcidState, HasAcidState(..))
import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Tiny.Events (GetPasteById(GetPasteById), GetRecentPastes(GetRecentPastes), InsertPaste(InsertPaste))
import Tiny.RouteAuth (App, AppForm, Route(..))
import Tiny.TemplateAuth (appTemplateHSP, appTemplateBlaze)
import Tiny.Types (Format(..), Paste(..), PasteId(..), PasteMeta(PasteMeta, format, nickname, pasteId, pasted, title))

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

-- | page handler for 'ViewRecent'
viewRecentPage :: App Response
viewRecentPage =
    do method GET
       recent <- query (GetRecentPastes 20 0)
       case recent of
         [] -> appTemplateHSP "Recent Pastes" () <p>There are no pastes yet.</p>
         _  -> appTemplateHSP "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 :: PasteId -> App Response
viewPastePage pid =
    do method GET
       mPaste <- query (GetPasteById pid)
       case mPaste of
         Nothing ->
             do notFound ()
                appTemplateHSP "Paste not found." () $
                    <p>Paste <% pid %> could not be found.</p>
         (Just (Paste (PasteMeta{..}) paste)) ->
             do ok ()
                appTemplateHSP (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 -> App XML
formatPaste PlainText txt =
    <pre><% txt %></pre>

-- | page handler for 'NewPaste'
newPastePage :: App Response
newPastePage =
    do here <- whereami
       acidAuth <- getAcidState
       acidProfile <- getAcidState
       mUserId <- getUserId acidAuth acidProfile
       case mUserId of
          Nothing ->
            appTemplateHSP "Add a Paste" () $
              <%>
                <h1>You Are Not Logged In</h1>
              </%>
          (Just _uid) ->
            appTemplateHSP "Add a Paste" () $
              <%>
                <h1>Add a paste</h1>
                <% reform (form here) "add" success Nothing pasteForm %>
              </%>
    where
      success :: Paste -> App Response
      success paste =
          do pid <- update (InsertPaste paste)
             seeOtherURL (ViewPaste pid)

-- | the 'Form' used for entering a new paste
pasteForm :: AppForm 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)))

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

-- | the route mapping function
route :: Text -> Route -> App Response
route 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
             acidAuth <- getAcidState
             acidProfile <- getAcidState
             XMLGenT $ nestURL U_AuthProfile $ handleAuthProfile acidAuth acidProfile (\s -> appTemplateBlaze acidAuth acidProfile (Lazy.pack s)) Nothing (Just baseURL) vr authProfileURL
      ViewRecent      -> viewRecentPage
      (ViewPaste pid) -> viewPastePage pid
      NewPaste        -> newPastePage
      CSS             -> serveFile (asContentType "text/css") "style.css"