Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , findChangedPagesAtRevision
   4     , loadPageInRepository
   5     )
   6     where
   7
   8 import           Control.Monad
   9 import           Data.List
  10 import qualified Data.Map as M
  11 import           Data.Maybe
  12 import           Data.Set (Set)
  13 import qualified Data.Set as S hiding (Set)
  14 import           Data.Time
  15 import           Network.HTTP.Lucu hiding (redirect)
  16 import           Rakka.Page
  17 import           Rakka.SystemConfig
  18 import           Rakka.Utils
  19 import           Rakka.W3CDateTime
  20 import           Subversion.Types
  21 import           Subversion.FileSystem
  22 import           Subversion.FileSystem.DirEntry
  23 import           Subversion.FileSystem.Revision
  24 import           Subversion.FileSystem.Root
  25 import           Subversion.Repository
  26 import           System.FilePath.Posix
  27
  28
  29 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  30 findAllPagesInRevision repos rev
  31     = do fs <- getRepositoryFS repos
  32          withRevision fs rev
  33              $ do exists <- isDirectory root
  34                   if exists then
  35                       traverse root
  36                     else
  37                       return S.empty
  38     where
  39       root :: FilePath
  40       root = "/pages"
  41
  42       traverse :: FilePath -> Rev (Set PageName)
  43       traverse dir
  44           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  45
  46       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  47       traverse' dir entry
  48           = let path = dir </> entName entry
  49             in
  50               do kind <- checkPath path
  51                  case kind of
  52                    NoNode   -> return S.empty
  53                    FileNode -> return $ S.singleton (decodePath path)
  54                    DirNode  -> traverse path
  55
  56       decodePath :: FilePath -> PageName
  57       decodePath = decodePageName . makeRelative root . dropExtension
  58
  59
  60 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
  61 findChangedPagesAtRevision repos rev
  62     = do fs <- getRepositoryFS repos
  63          withRevision fs rev
  64              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
  65     where
  66       accumulatePages :: Set PageName -> FilePath -> Set PageName
  67       accumulatePages s path
  68           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
  69               = let encoded = makeRelative "/pages" $ dropExtension path
  70                     name    = decodePageName encoded
  71                 in
  72                   S.insert name s
  73           | otherwise
  74               = s
  75
  76
  77 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  78 loadPageInRepository repos name rev
  79     = do fs   <- getRepositoryFS repos
  80          rev' <- case rev of
  81                    Nothing -> getYoungestRev fs
  82                    Just r  -> return r
  83          withRevision fs rev'
  84              $ do exists <- isFile path
  85                   case exists of
  86                     True
  87                         -> return . Just =<< loadPage'
  88                     False
  89                         -> return Nothing
  90     where
  91       path :: FilePath
  92       path = "pages" </> encodePageName name <.> "page"
  93
  94       loadPage' :: Rev Page
  95       loadPage' = do redirect <- getNodeProp path "rakka:redirect"
  96                      case redirect of
  97                        Nothing
  98                            -> loadPageEntity
  99                        Just _
 100                            -> loadPageRedirect
 101
 102       loadPageEntity :: Rev Page
 103       loadPageEntity
 104           = do props   <- getNodePropList path
 105                hist    <- getNodeHistory True path
 106                content <- getFileContentsLBS path
 107
 108                let pageRev  = fst $ head hist
 109                    mimeType = read
 110                               $ fromMaybe "text/x-rakka"
 111                               $ fmap chomp (lookup "svn:mime-type" props)
 112
 113                lastMod <- getRevisionProp "svn:date"
 114                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 115
 116                return Entity {
 117                             pageName      = name
 118                           , pageType      = mimeType
 119                           , pageLanguage  = fmap chomp (lookup "rakka:lang" props)
 120                           , pageFileName  = fmap chomp (lookup "rakka:fileName" props)
 121                           , pageIsTheme   = any ((== "rakka:isTheme") . fst) props
 122                           , pageIsFeed    = any ((== "rakka:isFeed") . fst) props
 123                           , pageIsLocked  = any ((== "rakka:isLocked") . fst) props
 124                           , pageIsBoring  = any ((== "rakka:isBoring") . fst) props
 125                           , pageIsBinary  = case mimeType of
 126                                               MIMEType "text" _ _
 127                                                   -> any ((== "rakka:isBinary") . fst) props
 128                                               _
 129                                                   -> True
 130                           , pageRevision  = pageRev
 131                           , pageLastMod   = zonedTimeToUTC lastMod
 132                           , pageSummary   = lookup "rakka:summary" props
 133                           , pageOtherLang = fromMaybe M.empty
 134                                             $ fmap
 135                                                   (M.fromList . fromJust . deserializeStringPairs)
 136                                                   (lookup "rakka:otherLang" props)
 137                           , pageContent   = content
 138                           }
 139
 140       loadPageRedirect :: Rev Page
 141       loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented"