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

import qualified Codec.Binary.Base64 as B64
import qualified Codec.Binary.UTF8.String as UTF8
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as Lazy
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 hiding (err)
import           Text.XML.HXT.Arrow.XmlNodeSet
import           Text.XML.HXT.DOM.TypeDefs


type InterpTable = Map String Interpreter


wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
wikifyPage interpTable
    = proc tree
    -> do pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< 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 interpTable) "" (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,...">
                       --   application/zip
                       -- </a>
                       returnA -< [ Paragraph [ Anchor
                                                [("href", show dataURI)]
                                                [Text (show pType)]
                                              ]
                                  ]
                   else
                       -- pre
                       returnA -< [ Preformatted [Text $ fromJust textData] ]
    where
      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


wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
wikifyBin interpTable
    = proc (pType, pBin)
    -> do let text    = UTF8.decode $ Lazy.unpack pBin
              dataURI = binToURI pType pBin

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

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

            
            _
                -- <a href="data:application/zip;base64,...">
                --   application/zip (19372 bytes)
                -- </a>
                -> returnA -< [ Paragraph [ Anchor
                                            [("href", show dataURI)]
                                            [Text (show pType ++
                                                   " (" ++
                                                   show (Lazy.length pBin) ++
                                                   " bytes)")]
                                          ]
                              ]
    where
      binToURI :: MIMEType -> Lazy.ByteString -> URI
      binToURI m b
          = nullURI {
              uriScheme = "data:"
            , uriPath   = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
            }


cmdTypeOf :: InterpTable -> String -> Maybe CommandType
cmdTypeOf interpTable name
    = fmap commandType (M.lookup name interpTable)


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, Just 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, fmap fst mainWiki, fmap snd mainWiki, subWiki)
          formatWikiBlocks -< (baseURI, interpreted)


makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                    Storage
                 -> SystemConfig
                 -> InterpTable
                 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
makePreviewXHTML sto sysConf interpTable
    = proc (name, pageType, pageBin)
    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
          wiki            <- wikifyBin interpTable -< (pageType, pageBin)
          interpreted     <- interpretCommands sto sysConf interpTable
                             -< (name, Nothing, Just wiki, wiki)
          formatWikiBlocks -< (baseURI, interpreted)


interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                     Storage
                  -> SystemConfig
                  -> InterpTable
                  -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
interpretCommands sto sysConf interpTable
    = proc (name, mainPage, mainWiki, targetWiki)
    -> let ctx = InterpreterContext {
                   ctxPageName   = name
                 , ctxMainPage   = mainPage
                 , ctxMainWiki   = mainWiki
                 , 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 redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
         case redir of
           Nothing -> makeEntityDraft   -< tree
           Just _  -> makeRedirectDraft -< tree
    where
      makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
      makeEntityDraft 
          = 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
               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: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

      makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
      makeRedirectDraft
          = proc tree ->
            do doc <- arrIO0 newDocument -< ()

               pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
               pRedir    <- getXPathTreesInDoc "/page/@redirect/text()"     >>> getText -< tree
               pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
               pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree

               arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
               arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
               arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")
               arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
               arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)

               -- リダイレクト先ページ名はテキストとして入れる
               arrIO2 addText -< (doc, pRedir)

               returnA -< doc

      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)]) ]]