Rakka/Wiki/Engine.hs

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