Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( InterpTable
   3     , xmlizePage
   4     , makeMainXHTML
   5     , makeSubXHTML
   6     , makeDraft
   7     )
   8     where
   9
  10 import qualified Codec.Binary.Base64 as B64
  11 import           Codec.Binary.UTF8.String
  12 import           Control.Arrow
  13 import           Control.Arrow.ArrowIO
  14 import           Control.Arrow.ArrowList
  15 import qualified Data.ByteString.Lazy as L
  16 import           Data.Map (Map)
  17 import qualified Data.Map as M
  18 import           Data.Maybe
  19 import           Data.Time
  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 {-
  41   <page name="Foo/Bar"
  42         type="text/x-rakka"
  43         lang="ja"            -- 存在しない場合もある
  44         fileName="bar.rakka" -- 存在しない場合もある
  45         isTheme="no"         -- text/css の場合のみ存在
  46         isFeed="no"          -- text/x-rakka の場合のみ存在
  47         isLocked="no"
  48         isBinary="no"
  49         revision="112">      -- デフォルトでない場合のみ存在
  50         lastModified="2000-01-01T00:00:00">
  51
  52     <summary>
  53         blah blah...
  54     </summary> -- 存在しない場合もある
  55
  56     <otherLang> -- 存在しない場合もある
  57       <link lang="ja" page="Bar/Baz" />
  58     </otherLang>
  59
  60     <!-- 何れか一方のみ -->
  61     <textData>
  62       blah blah...
  63     </textData>
  64     <binaryData>
  65       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
  66     </binaryData>
  67   </page>
  68 -}
  69 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
  70 xmlizePage
  71     = proc page
  72     -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page
  73           ( eelem "/"
  74             += ( eelem "page"
  75                  += sattr "name" (pageName page)
  76                  += sattr "type" (show $ pageType page)
  77                  += ( case pageLanguage page of
  78                         Just x  -> sattr "lang" x
  79                         Nothing -> none
  80                     )
  81                  += ( case pageFileName page of
  82                         Just x  -> sattr "fileName" x
  83                         Nothing -> none
  84                     )
  85                  += ( case pageType page of
  86                         MIMEType "text" "css" _
  87                             -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
  88                         MIMEType "text" "x-rakka" _
  89                             -> sattr "isFeed"  (yesOrNo $ pageIsFeed page)
  90                         _
  91                             -> none
  92                     )
  93                  += sattr "isLocked" (yesOrNo $ pageIsLocked page)
  94                  += sattr "isBoring" (yesOrNo $ pageIsBoring page)
  95                  += sattr "isBinary" (yesOrNo $ pageIsBinary page)
  96                  += sattr "revision" (show $ pageRevision page)
  97                  += sattr "lastModified" (formatW3CDateTime lastMod)
  98                  += ( case pageSummary page of
  99                         Just s  -> eelem "summary" += txt s
 100                         Nothing -> none
 101                     )
 102                  += ( if M.null (pageOtherLang page) then
 103                           none
 104                       else
 105                           selem "otherLang"
 106                                     [ eelem "link"
 107                                       += sattr "lang" lang
 108                                       += sattr "page" name
 109                                           | (lang, name) <- M.toList (pageOtherLang page) ]
 110                     )
 111                  += ( if pageIsBinary page then
 112                           ( eelem "binaryData"
 113                             += txt (B64.encode $ L.unpack $ pageContent page)
 114                           )
 115                       else
 116                           ( eelem "textData"
 117                             += txt (decode $ L.unpack $ pageContent page)
 118                           )
 119                     )
 120                )) -<< ()
 121
 122
 123 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
 124 wikifyPage interpTable
 125     = proc tree
 126     -> do pName      <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
 127           pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
 128           pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< tree
 129           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 130           base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 131
 132           let dataURI = fmap (binToURI pType) base64Data
 133
 134           case pType of
 135             MIMEType "text" "x-rakka" _
 136                 -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
 137                      Left err -> wikifyParseError -< err
 138                      Right xs -> returnA -< xs
 139
 140             MIMEType "image" _ _
 141                 -- <img src="data:image/png;base64,..." />
 142                 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
 143
 144             _   -> if isJust dataURI then
 145                        -- <a href="data:application/zip;base64,...">foo.zip</a>
 146                        returnA -< [ Paragraph [ Anchor
 147                                                 [("href", show dataURI)]
 148                                                 [Text (fromMaybe (defaultFileName pType pName) pFileName)]
 149                                               ]
 150                                   ]
 151                    else
 152                        -- pre
 153                        returnA -< [ Preformatted [Text $ fromJust textData] ]
 154     where
 155       cmdTypeOf :: String -> Maybe CommandType
 156       cmdTypeOf name
 157           = fmap commandType (M.lookup name interpTable)
 158
 159       binToURI :: MIMEType -> String -> URI
 160       binToURI pType base64Data
 161           = nullURI {
 162               uriScheme = "data:"
 163             , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
 164             }
 165
 166       stripWhiteSpace :: String -> String
 167       stripWhiteSpace []     = []
 168       stripWhiteSpace (x:xs)
 169           | x `elem` " \t\n" = stripWhiteSpace xs
 170           | otherwise        = x : stripWhiteSpace xs
 171
 172
 173 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 174                  Storage
 175               -> SystemConfig
 176               -> InterpTable
 177               -> a XmlTree XmlTree
 178 makeMainXHTML sto sysConf interpTable
 179     = proc tree
 180     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 181           wiki            <- wikifyPage interpTable -< tree
 182           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
 183           interpreted     <- interpretCommands sto sysConf interpTable
 184                              -< (pName, Just (tree, wiki), wiki)
 185           formatWikiBlocks -< (baseURI, interpreted)
 186
 187
 188 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 189                 Storage
 190              -> SystemConfig
 191              -> InterpTable
 192              -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
 193 makeSubXHTML sto sysConf interpTable
 194     = proc (mainPageName, mainPage, subPage)
 195     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 196           mainWiki        <- case mainPage of
 197                                Just page
 198                                    -> do wiki <- wikifyPage interpTable -< page
 199                                          returnA -< Just (page, wiki)
 200                                Nothing
 201                                    -> returnA -< Nothing
 202           subWiki         <- wikifyPage interpTable -< subPage
 203           interpreted     <- interpretCommands sto sysConf interpTable
 204                              -< (mainPageName, mainWiki, subWiki)
 205           formatWikiBlocks -< (baseURI, interpreted)
 206
 207
 208 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 209                      Storage
 210                   -> SystemConfig
 211                   -> InterpTable
 212                   -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
 213 interpretCommands sto sysConf interpTable
 214     = proc (name, mainPageAndWiki, targetWiki)
 215     -> let ctx = InterpreterContext {
 216                    ctxPageName   = name
 217                  , ctxMainPage   = fmap fst mainPageAndWiki
 218                  , ctxMainWiki   = fmap snd mainPageAndWiki
 219                  , ctxTargetWiki = targetWiki
 220                  , ctxStorage    = sto
 221                  , ctxSysConf    = sysConf
 222                  }
 223        in
 224          arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
 225     where
 226       interpElem :: InterpreterContext -> Element -> IO Element
 227       interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
 228       interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
 229
 230       interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
 231       interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
 232       interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
 233       interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
 234       interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
 235       interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
 236       interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
 237       interpBlock _ x = return x
 238
 239       interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
 240       interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
 241       interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
 242       interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
 243       interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
 244       interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
 245       interpInline _ x = return x
 246
 247       interpListItem :: InterpreterContext -> ListItem -> IO ListItem
 248       interpListItem = mapM . interpElem
 249
 250       interpDefinition :: InterpreterContext -> Definition -> IO Definition
 251       interpDefinition ctx (Definition term desc)
 252           = do term' <- mapM (interpInline ctx) term
 253                desc' <- mapM (interpInline ctx) desc
 254                return (Definition term' desc')
 255
 256       interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
 257       interpBlockCommand ctx cmd
 258           = case M.lookup (bCmdName cmd) interpTable of
 259               Nothing
 260                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 261
 262               Just interp
 263                   -> bciInterpret interp ctx cmd
 264                      >>=
 265                      interpBlock ctx
 266
 267       interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
 268       interpInlineCommand ctx cmd
 269           = case M.lookup (iCmdName cmd) interpTable of
 270               Nothing
 271                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 272
 273               Just interp
 274                   -> iciInterpret interp ctx cmd
 275                      >>=
 276                      interpInline ctx
 277
 278
 279 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
 280 makeDraft interpTable
 281     = proc tree ->
 282       do doc <- arrIO0 newDocument -< ()
 283
 284          pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
 285          pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
 286          pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
 287          pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
 288          pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
 289          pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
 290          pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 291          pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 292          pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
 293          pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
 294          pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
 295          pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
 296
 297          arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
 298          arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
 299          arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
 300          arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
 301          arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
 302          arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
 303          arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
 304          arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
 305          arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
 306          arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
 307          arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
 308
 309          arrIO2 addHiddenText -< (doc, pName)
 310
 311          case pSummary of
 312            Just s  -> arrIO2 addHiddenText -< (doc, s)
 313            Nothing -> returnA -< ()
 314
 315          -- otherLang はリンク先ページ名を hidden text で入れる。
 316          otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
 317          listA ( (arr fst &&& arrL snd)
 318                  >>>
 319                  arrIO2 addHiddenText
 320                  >>>
 321                  none
 322                ) -< (doc, otherLangs)
 323
 324          case read pType of
 325            MIMEType "text" "css" _
 326                -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
 327
 328            MIMEType "text" "x-rakka" _
 329                -- wikify して興味のある部分を addText する。
 330                -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
 331                      wiki <- wikifyPage interpTable -< tree
 332                      arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
 333
 334            MIMEType _ _ _
 335                -> returnA -< ()
 336
 337          returnA -< doc
 338     where
 339       addElemText :: Document -> Element -> IO ()
 340       addElemText doc (Block  b) = addBlockText  doc b
 341       addElemText doc (Inline i) = addInlineText doc i
 342
 343       addBlockText :: Document -> BlockElement -> IO ()
 344       addBlockText doc (Heading _ text)       = addText doc text
 345       addBlockText _    HorizontalLine        = return ()
 346       addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
 347       addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
 348       addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
 349       addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
 350       addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
 351       addBlockText _    EmptyBlock            = return ()
 352       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 353
 354       addInlineText :: Document -> InlineElement -> IO ()
 355       addInlineText doc (Text text)                       = addText doc text
 356       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
 357       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
 358       addInlineText doc (ObjectLink page Nothing)         = addText doc page
 359       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
 360                                                             >> addText doc text
 361       addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 362       addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 363                                                             >> addText doc text
 364       addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
 365       addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
 366                                                             >> addText doc text
 367       addInlineText _   (LineBreak _)                     = return ()
 368       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
 369       addInlineText doc (Image src alt)                   = do case src of
 370                                                                  Left  uri  -> addHiddenText doc (uriToString id uri "")
 371                                                                  Right page -> addHiddenText doc page
 372                                                                case alt of
 373                                                                  Just text -> addHiddenText doc text
 374                                                                  Nothing   -> return ()
 375       addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
 376       addInlineText _   (Input _)                         = return ()
 377       addInlineText _    EmptyInline                      = return ()
 378       addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
 379
 380       addListItemText :: Document -> ListItem -> IO ()
 381       addListItemText = mapM_ . addElemText
 382
 383       addDefinitionText :: Document -> Definition -> IO ()
 384       addDefinitionText doc (Definition term desc)
 385           = do mapM_ (addInlineText doc) term
 386                mapM_ (addInlineText doc) desc
 387
 388       addBlockCmdText :: Document -> BlockCommand -> IO ()
 389       addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
 390
 391       addInlineCmdText :: Document -> InlineCommand -> IO ()
 392       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 393
 394
 395 wikifyParseError :: Arrow a => a ParseError WikiPage
 396 wikifyParseError = proc err
 397                  -> returnA -< [Div [("class", "error")]
 398                                 [ Block (Preformatted [Text (show err)]) ]]