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           Control.Arrow
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Arrow.ArrowList
  14 import qualified Data.ByteString.Lazy as L
  15 import           Data.Encoding
  16 import           Data.Encoding.UTF8
  17 import           Data.Generics
  18 import           Data.Map (Map)
  19 import qualified Data.Map as M
  20 import           Data.Maybe
  21 import           Network.HTTP.Lucu
  22 import           Network.URI
  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
  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) => a Page XmlTree
  71 xmlizePage
  72     = proc 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 $ pageLastMod page)
  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" page
 109                                       | (lang, page) <- 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 (decodeLazy UTF8 $ pageContent page)
 118                       )
 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          ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
 226            >>>
 227            arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
 228          ) -<< targetWiki
 229     where
 230       interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
 231       interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
 232       interpBlockCmd _   others         = return others
 233
 234       interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
 235       interpBlockCmd' ctx cmd
 236           = case M.lookup (bCmdName cmd) interpTable of
 237               Nothing
 238                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 239
 240               Just interp
 241                   -> bciInterpret interp ctx cmd
 242
 243
 244       interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
 245       interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
 246       interpInlineCmd _   others          = return others
 247
 248       interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
 249       interpInlineCmd' ctx cmd
 250           = case M.lookup (iCmdName cmd) interpTable of
 251               Nothing
 252                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 253
 254               Just interp
 255                   -> iciInterpret interp ctx cmd
 256
 257
 258 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
 259 makeDraft interpTable
 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          pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
 268          pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
 269          pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 270          pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 271          pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
 272          pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
 273          pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
 274          pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
 275
 276          arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
 277          arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
 278          arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
 279          arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
 280          arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
 281          arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
 282          arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
 283          arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
 284          arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
 285          arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
 286          arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
 287
 288          arrIO2 addHiddenText -< (doc, pName)
 289
 290          case pSummary of
 291            Just s  -> arrIO2 addHiddenText -< (doc, s)
 292            Nothing -> returnA -< ()
 293
 294          -- otherLang はリンク先ページ名を hidden text で入れる。
 295          otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
 296          listA ( (arr fst &&& arrL snd)
 297                  >>>
 298                  arrIO2 addHiddenText
 299                  >>>
 300                  none
 301                ) -< (doc, otherLangs)
 302
 303          case read pType of
 304            MIMEType "text" "css" _
 305                -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
 306
 307            MIMEType "text" "x-rakka" _
 308                -- wikify して興味のある部分を addText する。
 309                -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
 310                      wikiPage <- wikifyPage interpTable -< tree
 311                      arrIO0 (everywhereM' (mkM (addBlockText  doc)) wikiPage) -<< ()
 312                      arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< ()
 313                      returnA -< ()
 314
 315            MIMEType _ _ _
 316                -> returnA -< ()
 317
 318          returnA -< doc
 319     where
 320       addBlockText :: Document -> BlockElement -> IO BlockElement
 321       addBlockText doc b
 322           = do case b of
 323                  Heading _ text
 324                      -> addText doc text
 325                  _   -> return ()
 326                return b
 327
 328       addInlineText :: Document -> InlineElement -> IO InlineElement
 329       addInlineText doc i
 330           = do case i of
 331                  Text text
 332                      -> addText doc text
 333                  ObjectLink page Nothing
 334                      -> addText doc page
 335                  ObjectLink page (Just text)
 336                      -> do addHiddenText doc page
 337                            addText doc text
 338                  PageLink page fragment Nothing
 339                      -> addText doc (fromMaybe "" page ++
 340                                      fromMaybe "" fragment)
 341                  PageLink page fragment (Just text)
 342                      -> do addHiddenText doc (fromMaybe "" page ++
 343                                               fromMaybe "" fragment)
 344                            addText doc text
 345                  ExternalLink uri Nothing
 346                      -> addText doc (uriToString id uri "")
 347                  ExternalLink uri (Just text)
 348                      -> do addHiddenText doc (uriToString id uri "")
 349                            addText doc text
 350                  _   -> return ()
 351                return i
 352
 353 -- Perform monadic transformation in top-down order.
 354 everywhereM' :: Monad m => GenericM m -> GenericM m
 355 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 356
 357
 358 wikifyParseError :: Arrow a => a ParseError WikiPage
 359 wikifyParseError = proc err
 360                  -> returnA -< [Div [("class", "error")]
 361                                 [ Block (Preformatted [Text (show err)]) ]]