Rakka/Wiki/Engine.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , OverloadedStrings
   4   , ScopedTypeVariables
   5   , TypeOperators
   6   , UnicodeSyntax
   7   #-}
   8 module Rakka.Wiki.Engine
   9     ( InterpTable
  10     , makeMainXHTML
  11     , makeSubXHTML
  12     , makePreviewXHTML
  13     , makePageLinkList
  14     , makeDraft
  15     )
  16     where
  17 import Control.Applicative
  18 import Control.Arrow
  19 import Control.Arrow.ArrowIO
  20 import Control.Arrow.ArrowList
  21 import Control.Arrow.Unicode
  22 import Control.Monad.Unicode
  23 import qualified Codec.Binary.UTF8.String as UTF8
  24 import qualified Data.ByteString.Lazy as Lazy
  25 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
  26 import           Data.Map (Map)
  27 import qualified Data.Map as M
  28 import           Data.Maybe
  29 import Data.Monoid.Unicode
  30 import Data.Text (Text)
  31 import qualified Data.Text as T
  32 import           Network.HTTP.Lucu
  33 import           Network.URI
  34 import           OpenSSL.EVP.Base64
  35 import Prelude.Unicode
  36 import           Rakka.Page
  37 import           Rakka.Storage
  38 import           Rakka.SystemConfig
  39 import           Rakka.Utils
  40 import           Rakka.Wiki
  41 import           Rakka.Wiki.Parser
  42 import           Rakka.Wiki.Formatter
  43 import           Rakka.Wiki.Interpreter
  44 import           Text.HyperEstraier hiding (getText)
  45 import           Text.ParserCombinators.Parsec
  46 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
  47 import Text.XML.HXT.DOM.TypeDefs
  48 import Text.XML.HXT.XPath
  49
  50 type InterpTable = Map Text Interpreter
  51
  52 wikifyPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → XmlTree ⇝ WikiPage
  53 wikifyPage interpTable
  54     = proc tree
  55     → do pType      ← getXPathTreesInDoc "/page/@type/text()" ⋙ getText ⋙ arr read   ⤙ tree
  56          textData   ← maybeA (getXPathTreesInDoc "/page/textData/text()"   ⋙ getText) ⤙ tree
  57          base64Data ← maybeA (getXPathTreesInDoc "/page/binaryData/text()" ⋙ getText) ⤙ tree
  58
  59          let dataURI = binToURI pType <$> base64Data
  60
  61          case pType of
  62            MIMEType "text" "x-rakka" _
  63                → case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
  64                     Left err → wikifyParseError ⤙ err
  65                     Right xs → returnA ⤙ xs
  66
  67            MIMEType "image" _ _
  68                -- <img src="data:image/png;base64,..." />
  69                → returnA ⤙ [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
  70
  71            _   → if isJust dataURI then
  72                      -- <a href="data:application/zip;base64,...">
  73                      --   application/zip
  74                      -- </a>
  75                      returnA ⤙ [ Paragraph [ Anchor
  76                                                [("href", T.pack $ show dataURI)]
  77                                                [Text (T.pack $ show pType)]
  78                                            ]
  79                                ]
  80                  else
  81                      -- pre
  82                      returnA ⤙ [ Preformatted [Text ∘ T.pack $ fromJust textData] ]
  83     where
  84       binToURI :: MIMEType -> String -> URI
  85       binToURI pType base64Data
  86           = nullURI {
  87               uriScheme = "data:"
  88             , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
  89             }
  90
  91       stripWhiteSpace :: String -> String
  92       stripWhiteSpace []     = []
  93       stripWhiteSpace (x:xs)
  94           | x `elem` " \t\n" = stripWhiteSpace xs
  95           | otherwise        = x : stripWhiteSpace xs
  96
  97
  98 wikifyBin :: (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → (MIMEType, Lazy.ByteString) ⇝ WikiPage
  99 wikifyBin interpTable
 100     = proc (pType, pBin)
 101     → do let text    = UTF8.decode $ Lazy.unpack pBin
 102              dataURI = binToURI pType pBin
 103
 104          case pType of
 105            MIMEType "text" "x-rakka" _
 106                -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
 107                     Left err -> wikifyParseError -< err
 108                     Right xs -> returnA -< xs
 109
 110            MIMEType "image" _ _
 111                -- <img src="data:image/png;base64,..." />
 112                -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
 113
 114            _   -- <a href="data:application/zip;base64,...">
 115                --   application/zip (19372 bytes)
 116                -- </a>
 117                -> returnA -< [ Paragraph [ Anchor
 118                                            [("href", T.pack $ show dataURI)]
 119                                            [Text (T.concat [ T.pack $ show pType
 120                                                            , "("
 121                                                            , T.pack ∘ show $ Lazy.length pBin
 122                                                            , " bytes)"
 123                                                            ])]
 124                                          ]
 125                              ]
 126     where
 127       binToURI :: MIMEType -> Lazy.ByteString -> URI
 128       binToURI m b
 129           = nullURI {
 130               uriScheme = "data:"
 131             , uriPath   = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
 132             }
 133
 134 cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType
 135 cmdTypeOf interpTable name
 136     = case M.lookup name interpTable of
 137         Just t  → pure $ commandType t
 138         Nothing → empty
 139
 140 makeMainXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 141               ⇒ Storage
 142               → SystemConfig
 143               → InterpTable
 144               → XmlTree ⇝ XmlTree
 145 makeMainXHTML sto sysConf interpTable
 146     = proc tree
 147     → do BaseURI baseURI ← getSysConfA sysConf    ⤙ ()
 148          wiki            ← wikifyPage interpTable ⤙ tree
 149          pName           ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
 150          interpreted     ← interpretCommands sto sysConf interpTable
 151                            ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
 152          formatWikiBlocks ⤙ (baseURI, interpreted)
 153
 154
 155 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 156                 Storage
 157              -> SystemConfig
 158              -> InterpTable
 159              -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
 160 makeSubXHTML sto sysConf interpTable
 161     = proc (mainPageName, mainPage, subPage)
 162     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 163           mainWiki        <- case mainPage of
 164                                Just page
 165                                    -> do wiki <- wikifyPage interpTable -< page
 166                                          returnA -< Just (page, wiki)
 167                                Nothing
 168                                    -> returnA -< Nothing
 169           subWiki         <- wikifyPage interpTable -< subPage
 170           interpreted     <- interpretCommands sto sysConf interpTable
 171                              -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
 172           formatWikiBlocks -< (baseURI, interpreted)
 173
 174
 175 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 176                     Storage
 177                  -> SystemConfig
 178                  -> InterpTable
 179                  -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
 180 makePreviewXHTML sto sysConf interpTable
 181     = proc (name, pageType, pageBin)
 182     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 183           wiki            <- wikifyBin interpTable -< (pageType, pageBin)
 184           interpreted     <- interpretCommands sto sysConf interpTable
 185                              -< (Just name, Nothing, Just wiki, wiki)
 186           formatWikiBlocks -< (baseURI, interpreted)
 187
 188
 189 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 190                      Storage
 191                   -> SystemConfig
 192                   -> InterpTable
 193                   -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
 194 interpretCommands sto sysConf interpTable
 195     = proc (name, mainPage, mainWiki, targetWiki)
 196     -> let ctx = InterpreterContext {
 197                    ctxPageName   = name
 198                  , ctxMainPage   = mainPage
 199                  , ctxMainWiki   = mainWiki
 200                  , ctxTargetWiki = targetWiki
 201                  , ctxStorage    = sto
 202                  , ctxSysConf    = sysConf
 203                  }
 204        in
 205          arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
 206     where
 207       interpElem :: InterpreterContext -> Element -> IO Element
 208       interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
 209       interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
 210
 211       interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
 212       interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
 213       interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
 214       interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
 215       interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
 216       interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
 217       interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
 218       interpBlock _ x = return x
 219
 220       interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
 221       interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
 222       interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
 223       interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
 224       interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
 225       interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
 226       interpInline _ x = return x
 227
 228       interpListItem :: InterpreterContext -> ListItem -> IO ListItem
 229       interpListItem = mapM . interpElem
 230
 231       interpDefinition :: InterpreterContext -> Definition -> IO Definition
 232       interpDefinition ctx (Definition term desc)
 233           = do term' <- mapM (interpInline ctx) term
 234                desc' <- mapM (interpInline ctx) desc
 235                return (Definition term' desc')
 236
 237       interpBlockCommand ∷ InterpreterContext → BlockCommand → IO BlockElement
 238       interpBlockCommand ctx cmd
 239           = case M.lookup (bCmdName cmd) interpTable of
 240               Nothing
 241                   → fail ("no such interpreter: " ⊕ T.unpack (bCmdName cmd))
 242
 243               Just interp
 244                   → bciInterpret interp ctx cmd
 245                     ≫=
 246                     interpBlock ctx
 247
 248       interpInlineCommand ∷ InterpreterContext → InlineCommand → IO InlineElement
 249       interpInlineCommand ctx cmd
 250           = case M.lookup (iCmdName cmd) interpTable of
 251               Nothing
 252                   → fail ("no such interpreter: " ⊕ T.unpack (iCmdName cmd))
 253
 254               Just interp
 255                   → iciInterpret interp ctx cmd ≫= interpInline ctx
 256
 257 makeDraft ∷ ∀(⇝). (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) ⇒ InterpTable → XmlTree ⇝ Document
 258 makeDraft interpTable
 259     = proc tree →
 260       do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree
 261          case redir of
 262            Nothing → makeEntityDraft   ⤙ tree
 263            Just _  → makeRedirectDraft ⤙ tree
 264     where
 265       makeEntityDraft ∷ XmlTree ⇝ Document
 266       makeEntityDraft
 267           = proc tree →
 268             do doc ← arrIO0 newDocument ⤙ ()
 269
 270                pName     ← getXPathTreesInDoc "/page/@name/text()"         ⋙ getText ⤙ tree
 271                pType     ← getXPathTreesInDoc "/page/@type/text()"         ⋙ getText ⤙ tree
 272                pLastMod  ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree
 273                pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()"     ⋙ getText ⤙ tree
 274                pIsBinary ← getXPathTreesInDoc "/page/@isBinary/text()"     ⋙ getText ⤙ tree
 275                pRevision ← getXPathTreesInDoc "/page/@revision/text()"     ⋙ getText ⤙ tree
 276                pLang     ← maybeA (getXPathTreesInDoc "/page/@lang/text()"     ⋙ getText) ⤙ tree
 277                pIsTheme  ← maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  ⋙ getText) ⤙ tree
 278                pIsFeed   ← maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   ⋙ getText) ⤙ tree
 279                pSummary  ← maybeA (getXPathTreesInDoc "/page/summary/text()"   ⋙ getText) ⤙ tree
 280
 281                arrIO2 setURI                               ⤙ (doc, Just ∘ mkRakkaURI $ T.pack pName    )
 282                arrIO2 (flip setAttribute "@title"        ) ⤙ (doc, Just              $ T.pack pName    )
 283                arrIO2 (flip setAttribute "@type"         ) ⤙ (doc, Just              $ T.pack pType    )
 284                arrIO2 (flip setAttribute "@mdate"        ) ⤙ (doc, Just              $ T.pack pLastMod )
 285                arrIO2 (flip setAttribute "@lang"         ) ⤙ (doc, T.pack <$> pLang)
 286                arrIO2 (flip setAttribute "rakka:isLocked") ⤙ (doc, Just              $ T.pack pIsLocked)
 287                arrIO2 (flip setAttribute "rakka:isBinary") ⤙ (doc, Just              $ T.pack pIsBinary)
 288                arrIO2 (flip setAttribute "rakka:revision") ⤙ (doc, Just              $ T.pack pRevision)
 289                arrIO2 (flip setAttribute "rakka:summary" ) ⤙ (doc, T.pack <$> pSummary)
 290
 291                arrIO2 addHiddenText ⤙ (doc, T.pack pName)
 292
 293                case pSummary of
 294                  Just s  → arrIO2 addHiddenText ⤙ (doc, T.pack s)
 295                  Nothing → returnA ⤙ ()
 296
 297                -- otherLang はリンク先ページ名を hidden text で入れる。
 298                otherLangs ← listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" ⋙ getText) ⤙ tree
 299                listA ( (arr fst &&& arrL snd)
 300                        ⋙
 301                        arrIO2 addHiddenText
 302                        ⋙
 303                        none
 304                      ) ⤙ (doc, T.pack <$> otherLangs)
 305
 306                case read pType of
 307                  MIMEType "text" "css" _
 308                      → arrIO2 (flip setAttribute "rakka:isTheme") ⤙ (doc, T.pack <$> pIsTheme)
 309
 310                  MIMEType "text" "x-rakka" _
 311                      -- wikify して興味のある部分を addText する。
 312                      → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed)
 313                           wiki ← wikifyPage interpTable ⤙ tree
 314                           arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki)
 315
 316                  MIMEType _ _ _
 317                      → returnA ⤙ ()
 318
 319                returnA ⤙ doc
 320
 321       makeRedirectDraft ∷ XmlTree ⇝ Document
 322       makeRedirectDraft
 323           = proc tree →
 324             do doc ← arrIO0 newDocument ⤙ ()
 325
 326                pName     ← getXPathTreesInDoc "/page/@name/text()"         ⋙ getText ⤙ tree
 327                pRedir    ← getXPathTreesInDoc "/page/@redirect/text()"     ⋙ getText ⤙ tree
 328                pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()"     ⋙ getText ⤙ tree
 329                pRevision ← getXPathTreesInDoc "/page/@revision/text()"     ⋙ getText ⤙ tree
 330                pLastMod  ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree
 331
 332                arrIO2 setURI                               -< (doc, Just ∘ mkRakkaURI $ T.pack pName      )
 333                arrIO2 (flip setAttribute "@title"        ) -< (doc, Just              $ T.pack pName      )
 334                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")
 335                arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just              $ T.pack pLastMod   )
 336                arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just              $ T.pack pIsLocked  )
 337                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just              $ T.pack pRevision  )
 338
 339                -- リダイレクト先ページ名はテキストとして入れる
 340                arrIO2 addText ⤙ (doc, T.pack pRedir)
 341
 342                returnA ⤙ doc
 343
 344       addElemText :: Document -> Element -> IO ()
 345       addElemText doc (Block  b) = addBlockText  doc b
 346       addElemText doc (Inline i) = addInlineText doc i
 347
 348       addBlockText :: Document -> BlockElement -> IO ()
 349       addBlockText doc (Heading _ text)       = addText doc text
 350       addBlockText _    HorizontalLine        = return ()
 351       addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
 352       addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
 353       addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
 354       addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
 355       addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
 356       addBlockText _    EmptyBlock            = return ()
 357       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 358
 359       addInlineText ∷ Document → InlineElement → IO ()
 360       addInlineText doc (Text text)                       = addText doc text
 361       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
 362       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
 363       addInlineText doc (ObjectLink page Nothing)         = addText doc page
 364       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
 365                                                             *> addText    doc text
 366       addInlineText doc (PageLink page fragm Nothing)     = addText       doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
 367       addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
 368                                                             *> addText    doc text
 369       addInlineText doc (ExternalLink uri Nothing)        = addText       doc (T.pack $ uriToString id uri "")
 370       addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (T.pack $ uriToString id uri "")
 371                                                             *> addText    doc text
 372       addInlineText _   (LineBreak _)                     = return ()
 373       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
 374       addInlineText doc (Image src alt)                   = do case src of
 375                                                                  Left  uri  -> addHiddenText doc (T.pack $ uriToString id uri "")
 376                                                                  Right page -> addHiddenText doc page
 377                                                                case alt of
 378                                                                  Just text -> addHiddenText doc text
 379                                                                  Nothing   -> return ()
 380       addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
 381       addInlineText _   (Input _)                         = return ()
 382       addInlineText _    EmptyInline                      = return ()
 383       addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
 384
 385       addListItemText :: Document -> ListItem -> IO ()
 386       addListItemText = mapM_ . addElemText
 387
 388       addDefinitionText :: Document -> Definition -> IO ()
 389       addDefinitionText doc (Definition term desc)
 390           = do mapM_ (addInlineText doc) term
 391                mapM_ (addInlineText doc) desc
 392
 393       addBlockCmdText :: Document -> BlockCommand -> IO ()
 394       addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
 395
 396       addInlineCmdText :: Document -> InlineCommand -> IO ()
 397       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 398
 399
 400 makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 401                  ⇒ Storage
 402                  → SystemConfig
 403                  → InterpTable
 404                  → XmlTree ⇝ [PageName]
 405 makePageLinkList sto sysConf interpTable
 406     = proc tree
 407     → do wiki        ← wikifyPage interpTable ⤙ tree
 408          pName       ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
 409          interpreted ← interpretCommands sto sysConf interpTable
 410                        ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
 411          returnA ⤙ concatMap extractFromBlock interpreted
 412     where
 413       extractFromElem :: Element -> [PageName]
 414       extractFromElem (Block  b) = extractFromBlock  b
 415       extractFromElem (Inline i) = extractFromInline i
 416
 417       extractFromBlock :: BlockElement -> [PageName]
 418       extractFromBlock (List _ items)         = concatMap extractFromListItem items
 419       extractFromBlock (DefinitionList defs)  = concatMap extractFromDefinition defs
 420       extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
 421       extractFromBlock (Paragraph inlines)    = concatMap extractFromInline inlines
 422       extractFromBlock (Div _ elems)          = concatMap extractFromElem elems
 423       extractFromBlock _                      = []
 424
 425       extractFromInline :: InlineElement -> [PageName]
 426       extractFromInline (Italic inlines)           = concatMap extractFromInline inlines
 427       extractFromInline (Bold inlines)             = concatMap extractFromInline inlines
 428       extractFromInline (Span _ inlines)           = concatMap extractFromInline inlines
 429       extractFromInline (PageLink (Just name) _ _) = [name]
 430       extractFromInline _                          = []
 431
 432       extractFromListItem :: ListItem -> [PageName]
 433       extractFromListItem = concatMap extractFromElem
 434
 435       extractFromDefinition :: Definition -> [PageName]
 436       extractFromDefinition (Definition term desc)
 437           = concatMap extractFromInline term
 438             ++
 439             concatMap extractFromInline desc
 440
 441 wikifyParseError ∷ Arrow (⇝) ⇒ ParseError ⇝ WikiPage
 442 wikifyParseError = proc err
 443                  → returnA -< [Div [("class", "error")]
 444                                 [ Block (Preformatted [Text (T.pack $ show err)]) ]]