Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( InterpTable
   3     , makeMainXHTML
   4     , makeSubXHTML
   5     , makeDraft
   6     , makePreviewXHTML
   7     )
   8     where
   9
  10 import qualified Codec.Binary.Base64 as B64
  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           Data.Map (Map)
  17 import qualified Data.Map as M
  18 import           Data.Maybe
  19 import           Network.HTTP.Lucu
  20 import           Network.URI
  21 import           Rakka.Page
  22 import           Rakka.Storage
  23 import           Rakka.SystemConfig
  24 import           Rakka.Utils
  25 import           Rakka.Wiki
  26 import           Rakka.Wiki.Parser
  27 import           Rakka.Wiki.Formatter
  28 import           Rakka.Wiki.Interpreter
  29 import           Text.HyperEstraier hiding (getText)
  30 import           Text.ParserCombinators.Parsec
  31 import           Text.XML.HXT.Arrow.XmlArrow hiding (err)
  32 import           Text.XML.HXT.Arrow.XmlNodeSet
  33 import           Text.XML.HXT.DOM.TypeDefs
  34
  35
  36 type InterpTable = Map String Interpreter
  37
  38
  39 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
  40 wikifyPage interpTable
  41     = proc tree
  42     -> do pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
  43           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
  44           base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
  45
  46           let dataURI = fmap (binToURI pType) base64Data
  47
  48           case pType of
  49             MIMEType "text" "x-rakka" _
  50                 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
  51                      Left err -> wikifyParseError -< err
  52                      Right xs -> returnA -< xs
  53
  54             MIMEType "image" _ _
  55                 -- <img src="data:image/png;base64,..." />
  56                 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
  57
  58             _   -> if isJust dataURI then
  59                        -- <a href="data:application/zip;base64,...">
  60                        --   application/zip
  61                        -- </a>
  62                        returnA -< [ Paragraph [ Anchor
  63                                                 [("href", show dataURI)]
  64                                                 [Text (show pType)]
  65                                               ]
  66                                   ]
  67                    else
  68                        -- pre
  69                        returnA -< [ Preformatted [Text $ fromJust textData] ]
  70     where
  71       binToURI :: MIMEType -> String -> URI
  72       binToURI pType base64Data
  73           = nullURI {
  74               uriScheme = "data:"
  75             , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
  76             }
  77
  78       stripWhiteSpace :: String -> String
  79       stripWhiteSpace []     = []
  80       stripWhiteSpace (x:xs)
  81           | x `elem` " \t\n" = stripWhiteSpace xs
  82           | otherwise        = x : stripWhiteSpace xs
  83
  84
  85 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
  86 wikifyBin interpTable
  87     = proc (pType, pBin)
  88     -> do let text    = UTF8.decode $ Lazy.unpack pBin
  89               dataURI = binToURI pType pBin
  90
  91           case pType of
  92             MIMEType "text" "x-rakka" _
  93                 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
  94                      Left err -> wikifyParseError -< err
  95                      Right xs -> returnA -< xs
  96
  97             MIMEType "image" _ _
  98                 -- <img src="data:image/png;base64,..." />
  99                 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
 100
 101
 102             _
 103                 -- <a href="data:application/zip;base64,...">
 104                 --   application/zip (19372 bytes)
 105                 -- </a>
 106                 -> returnA -< [ Paragraph [ Anchor
 107                                             [("href", show dataURI)]
 108                                             [Text (show pType ++
 109                                                    " (" ++
 110                                                    show (Lazy.length pBin) ++
 111                                                    " bytes)")]
 112                                           ]
 113                               ]
 114     where
 115       binToURI :: MIMEType -> Lazy.ByteString -> URI
 116       binToURI m b
 117           = nullURI {
 118               uriScheme = "data:"
 119             , uriPath   = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
 120             }
 121
 122
 123 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
 124 cmdTypeOf interpTable name
 125     = fmap commandType (M.lookup name interpTable)
 126
 127
 128 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 129                  Storage
 130               -> SystemConfig
 131               -> InterpTable
 132               -> a XmlTree XmlTree
 133 makeMainXHTML sto sysConf interpTable
 134     = proc tree
 135     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 136           wiki            <- wikifyPage interpTable -< tree
 137           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
 138           interpreted     <- interpretCommands sto sysConf interpTable
 139                              -< (pName, Just tree, Just wiki, wiki)
 140           formatWikiBlocks -< (baseURI, interpreted)
 141
 142
 143 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 144                 Storage
 145              -> SystemConfig
 146              -> InterpTable
 147              -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
 148 makeSubXHTML sto sysConf interpTable
 149     = proc (mainPageName, mainPage, subPage)
 150     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 151           mainWiki        <- case mainPage of
 152                                Just page
 153                                    -> do wiki <- wikifyPage interpTable -< page
 154                                          returnA -< Just (page, wiki)
 155                                Nothing
 156                                    -> returnA -< Nothing
 157           subWiki         <- wikifyPage interpTable -< subPage
 158           interpreted     <- interpretCommands sto sysConf interpTable
 159                              -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
 160           formatWikiBlocks -< (baseURI, interpreted)
 161
 162
 163 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 164                     Storage
 165                  -> SystemConfig
 166                  -> InterpTable
 167                  -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
 168 makePreviewXHTML sto sysConf interpTable
 169     = proc (name, pageType, pageBin)
 170     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 171           wiki            <- wikifyBin interpTable -< (pageType, pageBin)
 172           interpreted     <- interpretCommands sto sysConf interpTable
 173                              -< (name, Nothing, Just wiki, wiki)
 174           formatWikiBlocks -< (baseURI, interpreted)
 175
 176
 177 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 178                      Storage
 179                   -> SystemConfig
 180                   -> InterpTable
 181                   -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
 182 interpretCommands sto sysConf interpTable
 183     = proc (name, mainPage, mainWiki, targetWiki)
 184     -> let ctx = InterpreterContext {
 185                    ctxPageName   = name
 186                  , ctxMainPage   = mainPage
 187                  , ctxMainWiki   = mainWiki
 188                  , ctxTargetWiki = targetWiki
 189                  , ctxStorage    = sto
 190                  , ctxSysConf    = sysConf
 191                  }
 192        in
 193          arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
 194     where
 195       interpElem :: InterpreterContext -> Element -> IO Element
 196       interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
 197       interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
 198
 199       interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
 200       interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
 201       interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
 202       interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
 203       interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
 204       interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
 205       interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
 206       interpBlock _ x = return x
 207
 208       interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
 209       interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
 210       interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
 211       interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
 212       interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
 213       interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
 214       interpInline _ x = return x
 215
 216       interpListItem :: InterpreterContext -> ListItem -> IO ListItem
 217       interpListItem = mapM . interpElem
 218
 219       interpDefinition :: InterpreterContext -> Definition -> IO Definition
 220       interpDefinition ctx (Definition term desc)
 221           = do term' <- mapM (interpInline ctx) term
 222                desc' <- mapM (interpInline ctx) desc
 223                return (Definition term' desc')
 224
 225       interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
 226       interpBlockCommand ctx cmd
 227           = case M.lookup (bCmdName cmd) interpTable of
 228               Nothing
 229                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 230
 231               Just interp
 232                   -> bciInterpret interp ctx cmd
 233                      >>=
 234                      interpBlock ctx
 235
 236       interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
 237       interpInlineCommand ctx cmd
 238           = case M.lookup (iCmdName cmd) interpTable of
 239               Nothing
 240                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 241
 242               Just interp
 243                   -> iciInterpret interp ctx cmd
 244                      >>=
 245                      interpInline ctx
 246
 247
 248 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
 249 makeDraft interpTable
 250     = proc tree ->
 251       do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
 252          case redir of
 253            Nothing -> makeEntityDraft   -< tree
 254            Just _  -> makeRedirectDraft -< tree
 255     where
 256       makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
 257       makeEntityDraft
 258           = proc tree ->
 259             do doc <- arrIO0 newDocument -< ()
 260
 261                pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
 262                pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
 263                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
 264                pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
 265                pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
 266                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 267                pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 268                pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/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:fileName") -< (doc, pFileName)
 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                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:revision") -< (doc, Just pRevision)
 329
 330                -- リダイレクト先ページ名はテキストとして入れる
 331                arrIO2 addText -< (doc, pRedir)
 332
 333                returnA -< doc
 334
 335       addElemText :: Document -> Element -> IO ()
 336       addElemText doc (Block  b) = addBlockText  doc b
 337       addElemText doc (Inline i) = addInlineText doc i
 338
 339       addBlockText :: Document -> BlockElement -> IO ()
 340       addBlockText doc (Heading _ text)       = addText doc text
 341       addBlockText _    HorizontalLine        = return ()
 342       addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
 343       addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
 344       addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
 345       addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
 346       addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
 347       addBlockText _    EmptyBlock            = return ()
 348       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 349
 350       addInlineText :: Document -> InlineElement -> IO ()
 351       addInlineText doc (Text text)                       = addText doc text
 352       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
 353       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
 354       addInlineText doc (ObjectLink page Nothing)         = addText doc page
 355       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
 356                                                             >> addText doc text
 357       addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 358       addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 359                                                             >> addText doc text
 360       addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
 361       addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
 362                                                             >> addText doc text
 363       addInlineText _   (LineBreak _)                     = return ()
 364       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
 365       addInlineText doc (Image src alt)                   = do case src of
 366                                                                  Left  uri  -> addHiddenText doc (uriToString id uri "")
 367                                                                  Right page -> addHiddenText doc page
 368                                                                case alt of
 369                                                                  Just text -> addHiddenText doc text
 370                                                                  Nothing   -> return ()
 371       addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
 372       addInlineText _   (Input _)                         = return ()
 373       addInlineText _    EmptyInline                      = return ()
 374       addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
 375
 376       addListItemText :: Document -> ListItem -> IO ()
 377       addListItemText = mapM_ . addElemText
 378
 379       addDefinitionText :: Document -> Definition -> IO ()
 380       addDefinitionText doc (Definition term desc)
 381           = do mapM_ (addInlineText doc) term
 382                mapM_ (addInlineText doc) desc
 383
 384       addBlockCmdText :: Document -> BlockCommand -> IO ()
 385       addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
 386
 387       addInlineCmdText :: Document -> InlineCommand -> IO ()
 388       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 389
 390
 391 wikifyParseError :: Arrow a => a ParseError WikiPage
 392 wikifyParseError = proc err
 393                  -> returnA -< [Div [("class", "error")]
 394                                 [ Block (Preformatted [Text (show err)]) ]]