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