-- Gitit plugin to convert the server request to JSON format and embed the resulting
-- JSON object on the rendered page, so client-side scripts can use it.
--
-- Required packages:
-- json (http://hackage.haskell.org/package/json)
--
-- Plugin is activated by a code block of the following format:
--
-- ~~~ {.req2json object="javascript_object_name"}
--
-- ~~~
--
-- The "object" parameter is optional: it sets the name of the Javascript object
-- to be embedded. If omitted, the object name will be "jsonreq". IF used, should be quoted.

{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}

module Req2JSON (plugin) where

import Text.JSON
import Text.XHtml
import Text.JSON.Generic
import Data.Data
import Data.Map (toList)
import Data.Maybe
import Data.Typeable
import Data.ByteString hiding (elem)
import Network.Gitit.Interface
import Happstack.Server.HTTP.Types
import Happstack.Server.Cookie

-- In order to convert the Happstack server request to JSON in generic way, we need
-- to derive certain instances externally.

deriving instance Data (Request)
deriving instance Data (Input)
deriving instance Data (Version)
deriving instance Data (RqBody)
deriving instance Data (HeaderPair)
deriving instance Data (Method)
deriving instance Data (ContentType)

deriving instance Typeable (Version)
deriving instance Typeable (HeaderPair)
deriving instance Typeable (Method)
deriving instance Typeable (ContentType)

plugin :: Plugin

plugin = mkPageTransformM transformBlock

-- Original Request keeps request headers as a Map. Map has problems with generic
-- data access, so here is a version of the request where Map is replaced with a list
-- of tuples.

data JSONReq = JSONReq {
  rjMethod :: Method
 ,rjPaths :: [String]
 ,rjUri :: String
 ,rjQuery :: String
 ,rjInputs :: [(String, Input)]
 ,rjCookies :: [(String, Cookie)]
 ,rjVersion :: Version
 ,rjHeaders :: [(ByteString, HeaderPair)]
 ,rjBody :: RqBody
 ,rjPeer :: Host} deriving (Data, Typeable)

-- Copy the request, item by item. Convert the map of headers to a list of tuples.

rq2rj :: Request -> JSONReq

rq2rj req = JSONReq {
  rjMethod = rqMethod req
 ,rjPaths = rqPaths req
 ,rjUri = rqUri req
 ,rjQuery = rqQuery req
 ,rjInputs = rqInputs req
 ,rjCookies = rqCookies req
 ,rjVersion = rqVersion req
 ,rjHeaders = toList $ rqHeaders req
 ,rjBody = rqBody req
 ,rjPeer = rqPeer req}

-- The content transformer: detect the code block activating the plugin,
-- find out the desired Javascript object name, encode the request as JSON,
-- embed the Javascript object on the page. If the page contains client-side
-- Javascript, the server requect parameters will be known to them via
-- this object.
-- Elements of the request will be accessible by Javascript properties same as
-- the original Haskell JSONReq data type members, e. g. rjMethod, rjQuery, etc.

transformBlock (CodeBlock (_, classes, namevals) contents) | "req2json" `elem` classes = do
  let obj = fromMaybe "jsonreq" $ lookup "object" namevals
  req <- askRequest
  doNotCache
  let jsonstr = "var " ++ obj ++ " = " ++ (encode $ toJSON_generic $ rq2rj req) ++ ";"
      tagscr = script ! [thetype "text/javascript"] << primHtml jsonstr
  return $ RawHtml $ showHtmlFragment tagscr

transformBlock x = return x