module Rakka.Wiki.Engine
    ( InterpTable
    , xmlizePage
    , makeMainXHTML
    , makeSubXHTML
    , makeDraft
    )
    where

import qualified Codec.Binary.Base64 as B64
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Generics
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import           Network.HTTP.Lucu
import           Network.URI
import           Rakka.Page
import           Rakka.Storage
import           Rakka.SystemConfig
import           Rakka.Utils
import           Rakka.Wiki
import           Rakka.Wiki.Parser
import           Rakka.Wiki.Formatter
import           Rakka.Wiki.Interpreter
import           Text.HyperEstraier hiding (getText)
import           Text.ParserCombinators.Parsec
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlNodeSet
import           Text.XML.HXT.DOM.TypeDefs


type InterpTable = Map String Interpreter


{-
  <page name="Foo/Bar"
        type="text/x-rakka"
        lang="ja"            -- 存在しない場合もある
        fileName="bar.rakka" -- 存在しない場合もある
        isTheme="no"         -- text/css の場合のみ存在
        isFeed="no"          -- text/x-rakka の場合のみ存在
        isLocked="no"
        isBinary="no"
        revision="112">      -- デフォルトでない場合のみ存在
        lastModified="2000-01-01T00:00:00">

    <summary>
        blah blah...
    </summary> -- 存在しない場合もある

    <otherLang> -- 存在しない場合もある
      <link lang="ja" page="Bar/Baz" />
    </otherLang>

    <!-- 何れか一方のみ -->
    <textData>
      blah blah...
    </textData>
    <binaryData>
      SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
    </binaryData>
  </page>
-}
xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
xmlizePage 
    = proc page
    -> (eelem "/"
        += ( eelem "page"
             += sattr "name" (pageName page)
             += sattr "type" (show $ pageType page)
             += ( case pageLanguage page of
                    Just x  -> sattr "lang" x
                    Nothing -> none
                )
             += ( case pageFileName page of
                    Just x  -> sattr "fileName" x
                    Nothing -> none
                )
             += ( case pageType page of
                    MIMEType "text" "css" _
                        -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
                    MIMEType "text" "x-rakka" _
                        -> sattr "isFeed"  (yesOrNo $ pageIsFeed page)
                    _
                        -> none
                )
             += sattr "isLocked" (yesOrNo $ pageIsLocked page)
             += sattr "isBoring" (yesOrNo $ pageIsBoring page)
             += sattr "isBinary" (yesOrNo $ pageIsBinary page)
             += sattr "revision" (show $ pageRevision page)
             += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
             += ( case pageSummary page of
                    Just s  -> eelem "summary" += txt s
                    Nothing -> none
                )
             += ( if M.null (pageOtherLang page) then
                      none
                  else
                      selem "otherLang"
                                [ eelem "link"
                                  += sattr "lang" lang
                                  += sattr "page" page
                                      | (lang, page) <- M.toList (pageOtherLang page) ]
                )
             += ( if pageIsBinary page then
                      ( eelem "binaryData"
                        += txt (B64.encode $ L.unpack $ pageContent page)
                      )
                  else
                      ( eelem "textData"
                        += txt (decodeLazy UTF8 $ pageContent page)
                      )
                )
           )
       ) -<< ()


wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
wikifyPage interpTable
    = proc tree
    -> do pName      <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
          pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
          pIsBinary  <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
          pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< tree
          textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree

          case pType of
            MIMEType "text" "x-rakka" _
                -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
                     Left err -> wikifyParseError -< err
                     Right xs -> returnA -< xs

            MIMEType "image" _ _
                -> returnA -< [ Paragraph [Image pName Nothing] ]

            _   -> if pIsBinary == "yes" then
                       returnA -< [ Paragraph [ ObjectLink {
                                                  objLinkPage = pName
                                                , objLinkText = Just $ fromMaybe (defaultFileName pType pName) pFileName
                                                }
                                              ]
                                  ]
                   else
                       -- pre
                       returnA -< [ Preformatted [Text $ fromJust textData] ]
    where
      cmdTypeOf :: String -> Maybe CommandType
      cmdTypeOf name
          = fmap commandType (M.lookup name interpTable)

      binToURI :: MIMEType -> String -> URI
      binToURI pType base64Data
          = nullURI {
              uriScheme = "data:"
            , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
            }

      stripWhiteSpace :: String -> String
      stripWhiteSpace []     = []
      stripWhiteSpace (x:xs)
          | x `elem` " \t\n" = stripWhiteSpace xs
          | otherwise        = x : stripWhiteSpace xs


makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                 Storage
              -> SystemConfig
              -> InterpTable
              -> a XmlTree XmlTree
makeMainXHTML sto sysConf interpTable
    = proc tree
    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
          wiki            <- wikifyPage interpTable -< tree
          pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
          interpreted     <- interpretCommands sto sysConf interpTable
                             -< (pName, Just (tree, wiki), wiki)
          formatWikiBlocks -< (baseURI, interpreted)


makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Storage
             -> SystemConfig
             -> InterpTable
             -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
makeSubXHTML sto sysConf interpTable
    = proc (mainPageName, mainPage, subPage)
    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
          mainWiki        <- case mainPage of
                               Just page
                                   -> do wiki <- wikifyPage interpTable -< page
                                         returnA -< Just (page, wiki)
                               Nothing
                                   -> returnA -< Nothing
          subWiki         <- wikifyPage interpTable -< subPage
          interpreted     <- interpretCommands sto sysConf interpTable
                             -< (mainPageName, mainWiki, subWiki)
          formatWikiBlocks -< (baseURI, interpreted)


interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                     Storage
                  -> SystemConfig
                  -> InterpTable
                  -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
interpretCommands sto sysConf interpTable
    = proc (name, mainPageAndWiki, targetWiki)
    -> let ctx = InterpreterContext {
                   ctxPageName   = name
                 , ctxMainPage   = fmap fst mainPageAndWiki
                 , ctxMainWiki   = fmap snd mainPageAndWiki
                 , ctxTargetWiki = targetWiki
                 , ctxStorage    = sto
                 , ctxSysConf    = sysConf
                 }
       in
         ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
           >>>
           arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
         ) -<< targetWiki
    where
      interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
      interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
      interpBlockCmd _   others         = return others

      interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
      interpBlockCmd' ctx cmd
          = case M.lookup (bCmdName cmd) interpTable of
              Nothing
                  -> fail ("no such interpreter: " ++ bCmdName cmd)

              Just interp
                  -> bciInterpret interp ctx cmd


      interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
      interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
      interpInlineCmd _   others          = return others

      interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
      interpInlineCmd' ctx cmd
          = case M.lookup (iCmdName cmd) interpTable of
              Nothing
                  -> fail ("no such interpreter: " ++ iCmdName cmd)

              Just interp
                  -> iciInterpret interp ctx cmd


makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
makeDraft interpTable
    = proc tree ->
      do doc <- arrIO0 newDocument -< ()
         
         pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
         pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
         pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
         pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
         pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
         pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
         pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
         pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
         pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
         pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
         pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
         pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree

         arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
         arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
         arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
         arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
         arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
         arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
         arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
         arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
         arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
         arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
         arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)

         arrIO2 addHiddenText -< (doc, pName)

         case pSummary of
           Just s  -> arrIO2 addHiddenText -< (doc, s)
           Nothing -> returnA -< ()

         -- otherLang はリンク先ページ名を hidden text で入れる。
         otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
         listA ( (arr fst &&& arrL snd)
                 >>>
                 arrIO2 addHiddenText
                 >>>
                 none
               ) -< (doc, otherLangs)

         case read pType of
           MIMEType "text" "css" _
               -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
           
           MIMEType "text" "x-rakka" _
               -- wikify して興味のある部分を addText する。
               -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
                     wikiPage <- wikifyPage interpTable -< tree
                     arrIO0 (everywhereM' (mkM (addBlockText  doc)) wikiPage) -<< ()
                     arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< ()
                     returnA -< ()

           MIMEType _ _ _
               -> returnA -< ()

         returnA -< doc
    where
      addBlockText :: Document -> BlockElement -> IO BlockElement
      addBlockText doc b
          = do case b of
                 Heading _ text
                     -> addText doc text
                 _   -> return ()
               return b

      addInlineText :: Document -> InlineElement -> IO InlineElement
      addInlineText doc i
          = do case i of
                 Text text
                     -> addText doc text
                 ObjectLink page Nothing
                     -> addText doc page
                 ObjectLink page (Just text)
                     -> do addHiddenText doc page
                           addText doc text
                 PageLink page fragment Nothing
                     -> addText doc (fromMaybe "" page ++
                                     fromMaybe "" fragment)
                 PageLink page fragment (Just text)
                     -> do addHiddenText doc (fromMaybe "" page ++
                                              fromMaybe "" fragment)
                           addText doc text
                 ExternalLink uri Nothing
                     -> addText doc (uriToString id uri "")
                 ExternalLink uri (Just text)
                     -> do addHiddenText doc (uriToString id uri "")
                           addText doc text
                 _   -> return ()
               return i

-- Perform monadic transformation in top-down order.
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' f x = f x >>= gmapM (everywhereM' f)


wikifyParseError :: Arrow a => a ParseError WikiPage
wikifyParseError = proc err
                 -> returnA -< [Div [("class", "error")]
                                [ Block (Preformatted [Text (show err)]) ]]