{-# LANGUAGE
    Arrows
  , TypeOperators
  , UnicodeSyntax
  #-}
module Rakka.Resource.Render
    ( resRender
    )
    where
import qualified Codec.Binary.UTF8.String as UTF8
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import           Control.Arrow.Unicode
import           Control.Monad.Trans
import Control.Monad.Unicode
import qualified Data.ByteString.Lazy as Lazy
import Data.Text as T
import           Network.HTTP.Lucu
import           OpenSSL.EVP.Base64
import Prelude.Unicode
import           Rakka.Environment
import           Rakka.Page
import           Rakka.Utils
import           Rakka.Wiki.Engine
import           System.FilePath.Posix
import           Text.XML.HXT.Arrow.Namespace
import           Text.XML.HXT.Arrow.WriteDocument
import           Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState
import           Text.XML.HXT.DOM.TypeDefs

resRender ∷ Environment → ResourceDef
resRender env
    = ResourceDef {
        resUsesNativeThread = False
      , resIsGreedy         = True
      , resGet              = Nothing
      , resHead             = Nothing
      , resPost             = Just $ getPathInfo ≫= handleRender env ∘ toPageName
      , resPut              = Nothing
      , resDelete           = Nothing
      }
    where
      toPageName ∷ [String] → PageName
      toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath

{-
  --- Request ---
  POST /render/Foo/Bar HTTP/1.0
  Content-Type: text/x-rakka
  
  = foo =
  blah blah...
  
  --- Response ---
  HTTP/1.1 200 OK
  Content-Type: text/xml
  
  <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
                name="Foo/Bar">
    <xhtml:h1>foo</xhtml:h1>
    <xhtml:p>
      blah blah...
    </xhtml:p>
  </renderResult>
-}
handleRender :: Environment -> PageName -> Resource ()
handleRender env name
    = do entity <- inputLBS defaultLimit
         cTypeM <- getContentType

         let (bin, cType) = case cTypeM of
                              Just (MIMEType "application" "x-rakka-base64-stream" _)
                                  -> let b = decodeBase64LBS entity
                                     in
                                       (b, guessMIMEType b)
                              Just t
                                  -> (entity, t)
                              Nothing
                                  -> (entity, guessMIMEType entity)

         setContentType $ read "text/xml"
         [xmlStr] ← liftIO $ runX ( setErrorMsgHandler False fail
                                    ⋙
                                    constA (name, cType, bin)
                                    ⋙
                                    render env
                                    ⋙
                                    writeDocumentToString [ withIndent yes
                                                          , withXmlPi  yes
                                                          ]
                                  )
         output $ UTF8.encodeString xmlStr

render ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
       ⇒ Environment
       → (PageName, MIMEType, Lazy.ByteString) ⇝ XmlTree
render env
    = proc (pName, pType, pBin)
    → do pageBody ← listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
                    ⤙ (pName, pType, pBin)
         ( eelem "/"
           += ( eelem "renderResult"
                += sattr "xmlns:xhtml" "http://www.w3.org/1999/xhtml"
                += sattr "name" (T.unpack pName)
                += constL pageBody
                ⋙
                uniqueNamespacesFromDeclAndQNames
              ) ) ⤛ ()