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

import qualified Codec.Binary.Base64 as B64
import           Codec.Binary.UTF8.String
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import           Data.Time
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 hiding (err)
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, ArrowIO a) => a Page XmlTree
xmlizePage 
    = proc page
    -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< 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 lastMod)
                 += ( 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" name
                                          | (lang, name) <- M.toList (pageOtherLang page) ]
                    )
                 += ( if pageIsBinary page then
                          ( eelem "binaryData"
                            += txt (B64.encode $ L.unpack $ pageContent page)
                          )
                      else
                          ( eelem "textData"
                            += txt (decode $ L.unpack $ 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
          pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< tree
          textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
          base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree

          let dataURI = fmap (binToURI pType) base64Data

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

            MIMEType "image" _ _
                -- <img src="data:image/png;base64,..." />
                -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]

            _   -> if isJust dataURI then
                       -- <a href="data:application/zip;base64,...">foo.zip</a>
                       returnA -< [ Paragraph [ Anchor
                                                [("href", show dataURI)]
                                                [Text (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
         arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
    where
      interpElem :: InterpreterContext -> Element -> IO Element
      interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
      interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline

      interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
      interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
      interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
      interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
      interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
      interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
      interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
      interpBlock _ x = return x

      interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
      interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
      interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
      interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
      interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
      interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
      interpInline _ x = return x

      interpListItem :: InterpreterContext -> ListItem -> IO ListItem
      interpListItem = mapM . interpElem

      interpDefinition :: InterpreterContext -> Definition -> IO Definition
      interpDefinition ctx (Definition term desc)
          = do term' <- mapM (interpInline ctx) term
               desc' <- mapM (interpInline ctx) desc
               return (Definition term' desc')

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

              Just interp
                  -> bciInterpret interp ctx cmd
                     >>=
                     interpBlock ctx

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

              Just interp
                  -> iciInterpret interp ctx cmd
                     >>=
                     interpInline ctx


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)
                     wiki <- wikifyPage interpTable -< tree
                     arrIO2 (mapM_ . addBlockText) -< (doc, wiki)

           MIMEType _ _ _
               -> returnA -< ()

         returnA -< doc
    where
      addElemText :: Document -> Element -> IO ()
      addElemText doc (Block  b) = addBlockText  doc b
      addElemText doc (Inline i) = addInlineText doc i

      addBlockText :: Document -> BlockElement -> IO ()
      addBlockText doc (Heading _ text)       = addText doc text
      addBlockText _    HorizontalLine        = return ()
      addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
      addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
      addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
      addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
      addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
      addBlockText _    EmptyBlock            = return ()
      addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd

      addInlineText :: Document -> InlineElement -> IO ()
      addInlineText doc (Text text)                       = addText doc text
      addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
      addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
      addInlineText doc (ObjectLink page Nothing)         = addText doc page
      addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
                                                            >> addText doc text
      addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
      addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
                                                            >> addText doc text
      addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
      addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
                                                            >> addText doc text
      addInlineText _   (LineBreak _)                     = return ()
      addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
      addInlineText doc (Image src alt)                   = do case src of
                                                                 Left  uri  -> addHiddenText doc (uriToString id uri "")
                                                                 Right page -> addHiddenText doc page
                                                               case alt of
                                                                 Just text -> addHiddenText doc text
                                                                 Nothing   -> return ()
      addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
      addInlineText _   (Input _)                         = return ()
      addInlineText _    EmptyInline                      = return ()
      addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd

      addListItemText :: Document -> ListItem -> IO ()
      addListItemText = mapM_ . addElemText

      addDefinitionText :: Document -> Definition -> IO ()
      addDefinitionText doc (Definition term desc)
          = do mapM_ (addInlineText doc) term
               mapM_ (addInlineText doc) desc

      addBlockCmdText :: Document -> BlockCommand -> IO ()
      addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks

      addInlineCmdText :: Document -> InlineCommand -> IO ()
      addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines


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