Rakka/Storage/DefaultPage.hs

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