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