{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Arrows #-}

module Bamboo.Plugin.Photo (photo) where

import Bamboo.Plugin.Photo.Config
import Data.ByteString.Lazy.Char8 (pack, unpack)
import Hack
import Hack.Contrib.Middleware.Censor
import MPSUTF8 hiding (at)
import Prelude hiding ((.), (>), (^), (/))
import Text.XML.HXT.Arrow hiding (first, mkText)
import Text.XML.HXT.Parser.HtmlParsec
import qualified Bamboo.Plugin.Photo.Model as Model
import qualified Bamboo.Plugin.Photo.View as View


photo :: Middleware
photo = censor code
  where
    code r = do
      bodies <- r.body.unpack.play
      let b = if bodies.null then r.body else bodies.first.pack
      return r {body = b}

play :: String -> IO [String]
play s = runX (processor s)


processor :: String -> IOSArrow XmlTree String
processor s =
  readString 
    [ (a_validate,"0")
    , (a_parse_html, "1")
    , (a_encoding, utf8)
    ] s
  > process_source
  > writeDocumentToString 
    [ (a_output_encoding, utf8)
    , (a_output_html, "1")
    , (a_no_empty_elements, "1")
    ]
  where
    process_source = processBottomUp (highlight_code `when` is_code_block)
    highlight_code = replaceChildren highlighted 
      > changeElemName (const $ mkName "div")
  
    highlighted = proc x -> do
      name        <- getAttrValue "name"                -< x
      prefix      <- getAttrValue "prefix"              -< x
      show_desc   <- getAttrValue "show_description"    -< x
      album_type  <- getAttrValue "album_type"          -< x 
      let {
        args = 
          [ ("name", name)
          , ("prefix", prefix)
          , ("show_description", show_desc)
          , ("album_type", album_type)
          ]
        }
      h <- arrIO plug -< args
      returnA -< parseHtmlContent h .first
  
    is_code_block = 
        isElem
      > hasName plugin_id
      > hasAttrValue plugin_type_key (is plugin_type_value)


-- album-plugin
-- <plugin type="photo" name="some-album" prefix="\d+-"

plug :: [(String, String)] -> IO String
plug args = args.Model.from_list ^ View.render ^ show