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