Rakka/Storage/DefaultPage.hs

   1 module Rakka.Storage.DefaultPage
   2     ( findAllDefaultPages
   3     , loadDefaultPage
   4     )
   5     where
   6
   7 import qualified Codec.Binary.Base64 as B64
   8 import           Control.Arrow
   9 import           Control.Arrow.ArrowIO
  10 import           Control.Arrow.ArrowList
  11 import qualified Data.ByteString.Lazy as L
  12 import           Data.Encoding
  13 import           Data.Encoding.UTF8
  14 import qualified Data.Map as M
  15 import           Data.Set (Set)
  16 import qualified Data.Set as S
  17 import           Paths_Rakka -- Cabal が用意する。
  18 import           Rakka.Page
  19 import           Rakka.Utils
  20 import           System.FilePath
  21 import           System.FilePath.Find
  22 import           System.Directory
  23 import           System.Time
  24 import           Text.XML.HXT.Arrow.ReadDocument
  25 import           Text.XML.HXT.Arrow.XmlArrow
  26 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  27 import           Text.XML.HXT.Arrow.XmlNodeSet
  28 import           Text.XML.HXT.DOM.TypeDefs
  29 import           Text.XML.HXT.DOM.XmlKeywords
  30
  31
  32 doesLocalDirExist :: IO Bool
  33 doesLocalDirExist = doesDirectoryExist "defaultPages"
  34
  35
  36 findAllDefaultPages :: IO (Set PageName)
  37 findAllDefaultPages
  38     -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
  39     -- defaultPages を探す。
  40     = do localDirExists <- doesLocalDirExist
  41          if localDirExists then
  42              findAllIn "defaultPages"
  43            else
  44              -- FIXME: この getDataFileName の使ひ方は undocumented
  45              findAllIn =<< getDataFileName "defaultPages"
  46     where
  47       findAllIn :: FilePath -> IO (Set PageName)
  48       findAllIn dirPath
  49           = find always (fileType ==? RegularFile) dirPath
  50             >>=
  51             return . S.fromList . map (decodePageName . makeRelative dirPath)
  52
  53
  54 loadDefaultPage :: PageName -> IO (Maybe Page)
  55 loadDefaultPage pageName
  56     -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
  57     -- ば Cabal で defaultPages/Foo を探す。
  58     = do let pagePath = "defaultPages/" ++ encodePageName pageName
  59
  60          localDirExists <- doesLocalDirExist
  61          if localDirExists then
  62              tryLoad pagePath
  63            else
  64              tryLoad =<< getDataFileName pagePath
  65     where
  66       tryLoad :: FilePath -> IO (Maybe Page)
  67       tryLoad fpath
  68           = do exists <- doesFileExist fpath
  69                if exists then
  70                    return . Just =<< loadPageFile pageName fpath
  71                  else
  72                    return Nothing
  73
  74
  75 loadPageFile :: PageName -> FilePath -> IO Page
  76 loadPageFile name path
  77     = do [page] <- runX ( setErrorMsgHandler False fail
  78                           >>>
  79                           constA (name, path)
  80                           >>>
  81                           loadPageFileA
  82                         )
  83          return page
  84
  85
  86 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
  87 loadPageFileA
  88     = proc (name, fpath) ->
  89       do tree    <- readFromDocument [ (a_validate         , v_0)
  90                                      , (a_check_namespaces , v_1)
  91                                      , (a_remove_whitespace, v_1)
  92                                      ] -< fpath
  93          lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
  94          parsePage -< (name, lastMod, tree)
  95
  96
  97 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
  98 parsePage
  99     = proc (name, lastMod, tree)
 100     -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 101           case redirect of
 102             Nothing   -> parseEntity -< (name, lastMod, tree)
 103             Just dest -> returnA     -< (Redirection {
 104                                            redirName     = name
 105                                          , redirDest     = dest
 106                                          , redirRevision = Nothing
 107                                          , redirLastMod  = lastMod
 108                                          })
 109
 110
 111 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
 112 parseEntity
 113     = proc (name, lastMod, tree)
 114     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
 115                        >>> arr read) -< tree
 116
 117           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
 118
 119           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 120                        >>> parseYesOrNo) -< tree
 121           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 122                        >>> parseYesOrNo) -< tree
 123           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 124                        >>> parseYesOrNo) -< tree
 125           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
 126                        >>> parseYesOrNo) -< tree
 127
 128           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 129                               >>> getText
 130                               >>> deleteIfEmpty)) -< tree
 131
 132           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 133                               >>>
 134                               (getAttrValue0 "lang"
 135                                &&&
 136                                getAttrValue0 "page")) -< tree
 137
 138           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 139           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 140
 141           let (isBinary, content)
 142                   = case (textData, binaryData) of
 143                       (Just text, _          ) -> (False, encodeLazy UTF8 text      )
 144                       (_        , Just binary) -> (True , L.pack $ B64.decode binary)
 145
 146           returnA -< Entity {
 147                         pageName      = name
 148                       , pageType      = mimeType
 149                       , pageLanguage  = lang
 150                       , pageIsTheme   = isTheme
 151                       , pageIsFeed    = isFeed
 152                       , pageIsLocked  = isLocked
 153                       , pageIsBoring  = isBoring
 154                       , pageIsBinary  = isBinary
 155                       , pageRevision  = 0
 156                       , pageLastMod   = lastMod
 157                       , pageSummary   = summary
 158                       , pageOtherLang = M.fromList otherLang
 159                       , pageContent   = content
 160                       }