{-# LANGUAGE
    Arrows
  , OverloadedStrings
  , ScopedTypeVariables
  , TypeOperators
  , UnicodeSyntax
  #-}
module Rakka.Wiki.Engine
    ( InterpTable
    , makeMainXHTML
    , makeSubXHTML
    , makePreviewXHTML
    , makePageLinkList
    , makeDraft
    )
    where
import Control.Applicative
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Control.Arrow.Unicode
import Control.Monad.Unicode
import qualified Codec.Binary.UTF8.String as UTF8
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import           Network.HTTP.Lucu
import           Network.URI
import           OpenSSL.EVP.Base64
import Prelude.Unicode
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.DOM.TypeDefs
import Text.XML.HXT.XPath

type InterpTable = Map Text Interpreter

wikifyPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → 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 = 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", T.pack $ show dataURI)]
                                               [Text (T.pack $ show pType)]
                                           ]
                               ]
                 else
                     -- pre
                     returnA ⤙ [ Preformatted [Text ∘ T.pack $ 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 (⇝), ArrowChoice (⇝)) ⇒ InterpTable → (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", T.pack $ show dataURI)]
                                           [Text (T.concat [ T.pack $ show pType
                                                           , "("
                                                           , T.pack ∘ show $ Lazy.length pBin
                                                           , " bytes)"
                                                           ])]
                                         ]
                             ]
    where
      binToURI :: MIMEType -> Lazy.ByteString -> URI
      binToURI m b
          = nullURI {
              uriScheme = "data:"
            , uriPath   = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
            }

cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType
cmdTypeOf interpTable name
    = case M.lookup name interpTable of
        Just t  → pure $ commandType t
        Nothing → empty

makeMainXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
              ⇒ Storage
              → SystemConfig
              → InterpTable
              → 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
                           ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
         formatWikiBlocks ⤙ (baseURI, interpreted)


makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Storage
             -> SystemConfig
             -> InterpTable
             -> a (Maybe 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
                             -< (Just name, Nothing, Just wiki, wiki)
          formatWikiBlocks -< (baseURI, interpreted)


interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                     Storage
                  -> SystemConfig
                  -> InterpTable
                  -> a (Maybe 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: " ⊕ T.unpack (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: " ⊕ T.unpack (iCmdName cmd))

              Just interp
                  → iciInterpret interp ctx cmd ≫= interpInline ctx

makeDraft ∷ ∀(⇝). (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) ⇒ InterpTable → XmlTree ⇝ Document
makeDraft interpTable
    = proc tree →
      do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree
         case redir of
           Nothing → makeEntityDraft   ⤙ tree
           Just _  → makeRedirectDraft ⤙ tree
    where
      makeEntityDraft ∷ 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
               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 $ T.pack pName    )
               arrIO2 (flip setAttribute "@title"        ) ⤙ (doc, Just              $ T.pack pName    )
               arrIO2 (flip setAttribute "@type"         ) ⤙ (doc, Just              $ T.pack pType    )
               arrIO2 (flip setAttribute "@mdate"        ) ⤙ (doc, Just              $ T.pack pLastMod )
               arrIO2 (flip setAttribute "@lang"         ) ⤙ (doc, T.pack <$> pLang)
               arrIO2 (flip setAttribute "rakka:isLocked") ⤙ (doc, Just              $ T.pack pIsLocked)
               arrIO2 (flip setAttribute "rakka:isBinary") ⤙ (doc, Just              $ T.pack pIsBinary)
               arrIO2 (flip setAttribute "rakka:revision") ⤙ (doc, Just              $ T.pack pRevision)
               arrIO2 (flip setAttribute "rakka:summary" ) ⤙ (doc, T.pack <$> pSummary)

               arrIO2 addHiddenText ⤙ (doc, T.pack pName)

               case pSummary of
                 Just s  → arrIO2 addHiddenText ⤙ (doc, T.pack 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, T.pack <$> otherLangs)

               case read pType of
                 MIMEType "text" "css" _
                     → arrIO2 (flip setAttribute "rakka:isTheme") ⤙ (doc, T.pack <$> pIsTheme)
           
                 MIMEType "text" "x-rakka" _
                     -- wikify して興味のある部分を addText する。
                     → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed)
                          wiki ← wikifyPage interpTable ⤙ tree
                          arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki)

                 MIMEType _ _ _
                     → returnA ⤙ ()

               returnA ⤙ doc

      makeRedirectDraft ∷ XmlTree ⇝ Document
      makeRedirectDraft
          = proc tree →
            do doc ← arrIO0 newDocument ⤙ ()

               pName     ← getXPathTreesInDoc "/page/@name/text()"         ⋙ getText ⤙ tree
               pRedir    ← getXPathTreesInDoc "/page/@redirect/text()"     ⋙ getText ⤙ tree
               pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()"     ⋙ getText ⤙ tree
               pRevision ← getXPathTreesInDoc "/page/@revision/text()"     ⋙ getText ⤙ tree
               pLastMod  ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree

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

               -- リダイレクト先ページ名はテキストとして入れる
               arrIO2 addText ⤙ (doc, T.pack 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 ⊕ maybe (∅) (T.cons '#') fragm)
      addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
                                                            *> addText    doc text
      addInlineText doc (ExternalLink uri Nothing)        = addText       doc (T.pack $ uriToString id uri "")
      addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (T.pack $ 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 (T.pack $ 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


makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
                 ⇒ Storage
                 → SystemConfig
                 → InterpTable
                 → XmlTree ⇝ [PageName]
makePageLinkList sto sysConf interpTable
    = proc tree
    → do wiki        ← wikifyPage interpTable ⤙ tree
         pName       ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
         interpreted ← interpretCommands sto sysConf interpTable
                       ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
         returnA ⤙ concatMap extractFromBlock interpreted
    where
      extractFromElem :: Element -> [PageName]
      extractFromElem (Block  b) = extractFromBlock  b
      extractFromElem (Inline i) = extractFromInline i

      extractFromBlock :: BlockElement -> [PageName]
      extractFromBlock (List _ items)         = concatMap extractFromListItem items
      extractFromBlock (DefinitionList defs)  = concatMap extractFromDefinition defs
      extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
      extractFromBlock (Paragraph inlines)    = concatMap extractFromInline inlines
      extractFromBlock (Div _ elems)          = concatMap extractFromElem elems
      extractFromBlock _                      = []

      extractFromInline :: InlineElement -> [PageName]
      extractFromInline (Italic inlines)           = concatMap extractFromInline inlines
      extractFromInline (Bold inlines)             = concatMap extractFromInline inlines
      extractFromInline (Span _ inlines)           = concatMap extractFromInline inlines
      extractFromInline (PageLink (Just name) _ _) = [name]
      extractFromInline _                          = []

      extractFromListItem :: ListItem -> [PageName]
      extractFromListItem = concatMap extractFromElem

      extractFromDefinition :: Definition -> [PageName]
      extractFromDefinition (Definition term desc)
          = concatMap extractFromInline term
            ++
            concatMap extractFromInline desc

wikifyParseError ∷ Arrow (⇝) ⇒ ParseError ⇝ WikiPage
wikifyParseError = proc err
                 → returnA -< [Div [("class", "error")]
                                [ Block (Preformatted [Text (T.pack $ show err)]) ]]