Rakka/Storage/DefaultPage.hs

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