Rakka/Page/Loader/DefaultPage.hs

   1 module Rakka.Page.Loader.DefaultPage
   2     ( loadDefaultPage
   3     )
   4     where
   5
   6 import qualified Codec.Binary.Base64.String as B64
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import qualified Data.ByteString.Lazy.Char8 as L8
  10 import           Paths_Rakka -- Cabal が用意する。
  11 import           Rakka.Page
  12 import           Rakka.Utils
  13 import           System.Directory
  14 import           Text.XML.HXT.Arrow.ReadDocument
  15 import           Text.XML.HXT.Arrow.XmlArrow
  16 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  17 import           Text.XML.HXT.Arrow.XmlNodeSet
  18 import           Text.XML.HXT.DOM.TypeDefs
  19 import           Text.XML.HXT.DOM.XmlKeywords
  20
  21
  22 loadDefaultPage :: PageName -> IO (Maybe Page)
  23 loadDefaultPage pageName
  24     -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
  25     = do let pagePath = encodePageName pageName
  26          isInDataDir <- doesFileExist ("./data/" ++ pagePath)
  27          if isInDataDir then
  28              return . Just =<< loadPageFile ("./data/" ++ pagePath)
  29            else
  30              do fpath       <- getDataFileName ("defaultPages/" ++ pagePath)
  31                 isInstalled <- doesFileExist fpath
  32                 if isInstalled then
  33                     return . Just =<< loadPageFile fpath
  34                   else
  35                     return Nothing
  36
  37
  38 loadPageFile :: FilePath -> IO Page
  39 loadPageFile path
  40     = do [page] <- runX ( constA path
  41                           >>>
  42                           loadPageFileA
  43                         )
  44          return page
  45
  46
  47 loadPageFileA :: IOStateArrow s FilePath Page
  48 loadPageFileA = ( readFromDocument [ (a_validate         , v_0)
  49                                    , (a_check_namespaces , v_1)
  50                                    , (a_remove_whitespace, v_1)
  51                                    ]
  52                   >>>
  53                   parsePage
  54                 )
  55
  56
  57 parsePage :: (ArrowXml a, ArrowChoice a) => a XmlTree Page
  58 parsePage
  59     = proc tree -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
  60                                    >>> arr read) -< tree
  61
  62                       isTheme  <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
  63                                    >>> defaultTo "no"
  64                                    >>> parseYesOrNo) -< tree
  65                       isFeed   <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
  66                                    >>> defaultTo "no"
  67                                    >>> parseYesOrNo) -< tree
  68                       isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
  69                                    >>> defaultTo "no"
  70                                    >>> parseYesOrNo) -< tree
  71                       isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
  72                                    >>> defaultTo "no"
  73                                    >>> parseYesOrNo) -< tree
  74
  75                       summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
  76                                           >>> getText
  77                                           >>> deleteIfEmpty)) -< tree
  78
  79                       otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
  80                                           >>>
  81                                           (getAttrValue0 "lang"
  82                                            &&&
  83                                            getAttrValue0 "page")) -< tree
  84
  85                       textData   <- maybeA (getXPathTreesInDoc "/page/textData"   >>> getText) -< tree
  86                       binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
  87
  88                       let content = case (textData, binaryData) of
  89                                       (Just text, _          ) -> L8.pack text
  90                                       (_        , Just binary) -> L8.pack $ B64.decode binary
  91
  92                       returnA -< Page {
  93                                     pageType      = mimeType
  94                                   , pageIsTheme   = isTheme
  95                                   , pageIsFeed    = isFeed
  96                                   , pageIsLocked  = isLocked
  97                                   , pageIsBoring  = isBoring
  98                                   , pageSummary   = summary
  99                                   , pageOtherLang = otherLang
 100                                   , pageContent   = content
 101                                   }