Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , getDirContentsInRevision
   4     , findChangedPagesAtRevision
   5     , loadPageInRepository
   6     , putPageIntoRepository
   7     , deletePageFromRepository
   8     )
   9     where
  10
  11 import           Codec.Binary.UTF8.String
  12 import           Control.Exception
  13 import           Control.Monad
  14 import           Data.List
  15 import qualified Data.Map as M
  16 import           Data.Maybe
  17 import           Data.Set (Set)
  18 import qualified Data.Set as S hiding (Set)
  19 import           Data.Time
  20 import           Network.HTTP.Lucu hiding (redirect)
  21 import           Rakka.Page
  22 import           Rakka.SystemConfig
  23 import           Rakka.Utils
  24 import           Rakka.W3CDateTime
  25 import           Subversion.Error
  26 import           Subversion.FileSystem
  27 import           Subversion.FileSystem.DirEntry
  28 import           Subversion.FileSystem.Revision
  29 import           Subversion.FileSystem.Root
  30 import           Subversion.FileSystem.Transaction
  31 import           Subversion.Repository
  32 import           Subversion.Types
  33 import           System.FilePath.Posix
  34
  35
  36 mkPagePath :: PageName -> FilePath
  37 mkPagePath name
  38     = "/pages" </> encodePageName name <.> "page"
  39
  40
  41 mkDirPath :: PageName -> FilePath
  42 mkDirPath dir
  43     = "/pages" </> encodePageName dir
  44
  45
  46 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  47 findAllPagesInRevision repos rev
  48     = do fs <- getRepositoryFS repos
  49          withRevision fs rev
  50              $ do exists <- isDirectory root
  51                   if exists then
  52                       traverse root
  53                     else
  54                       return S.empty
  55     where
  56       root :: FilePath
  57       root = "/pages"
  58
  59       traverse :: FilePath -> Rev (Set PageName)
  60       traverse dir
  61           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  62
  63       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  64       traverse' dir entry
  65           = let path = dir </> entName entry
  66             in
  67               do kind <- checkPath path
  68                  case kind of
  69                    NoNode   -> return S.empty
  70                    FileNode -> return $ S.singleton (decodePath path)
  71                    DirNode  -> traverse path
  72
  73       decodePath :: FilePath -> PageName
  74       decodePath = decodePageName . makeRelative root . dropExtension
  75
  76
  77 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
  78 getDirContentsInRevision repos dir 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 <- isDirectory path
  85                   if exists then
  86                       return . S.fromList =<< getDir'
  87                     else
  88                       return S.empty
  89     where
  90       path :: FilePath
  91       path = mkDirPath dir
  92
  93       getDir' :: Rev [PageName]
  94       getDir' = getDirEntries path >>= return . map entToName
  95
  96       entToName :: DirEntry -> PageName
  97       entToName = (dir </>) . decodePageName . dropExtension . entName
  98
  99
 100 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
 101 findChangedPagesAtRevision repos rev
 102     = do fs <- getRepositoryFS repos
 103          withRevision fs rev
 104              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
 105     where
 106       accumulatePages :: Set PageName -> FilePath -> Set PageName
 107       accumulatePages s path
 108           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
 109               = let encoded = makeRelative "/pages" $ dropExtension path
 110                     name    = decodePageName encoded
 111                 in
 112                   S.insert name s
 113           | otherwise
 114               = s
 115
 116
 117 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
 118 loadPageInRepository repos name rev
 119     = do fs   <- getRepositoryFS repos
 120          rev' <- case rev of
 121                    Nothing -> getYoungestRev fs
 122                    Just r  -> return r
 123          withRevision fs rev'
 124              $ do exists <- isFile path
 125                   if exists then
 126                       return . Just =<< loadPage'
 127                     else
 128                       return Nothing
 129     where
 130       path :: FilePath
 131       path = mkPagePath name
 132
 133       loadPage' :: Rev Page
 134       loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
 135                      case mType of
 136                        Just (MIMEType "application" "x-rakka-redirection" _)
 137                            -> loadPageRedirect
 138                        _
 139                            -> loadPageEntity
 140
 141       loadPageEntity :: Rev Page
 142       loadPageEntity
 143           = do props   <- getNodePropList path
 144                hist    <- getNodeHistory True path
 145                content <- getFileContentsLBS path
 146
 147                let pageRev  = fst $ head hist
 148                    mimeType = read
 149                               $ fromMaybe "text/x-rakka"
 150                               $ fmap chomp (lookup "svn:mime-type" props)
 151
 152                lastMod <- getRevisionProp "svn:date"
 153                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 154
 155                return Entity {
 156                             entityName       = name
 157                           , entityType       = mimeType
 158                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 159                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 160                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 161                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 162                           , entityIsBinary   = case mimeType of
 163                                                  MIMEType "text" _ _
 164                                                      -> any ((== "rakka:isBinary") . fst) props
 165                                                  _
 166                                                      -> True
 167                           , entityRevision   = pageRev
 168                           , entityLastMod    = zonedTimeToUTC lastMod
 169                           , entitySummary    = lookup "rakka:summary" props
 170                           , entityOtherLang  = fromMaybe M.empty
 171                                              $ fmap
 172                                                    (M.fromList . fromJust . deserializeStringPairs)
 173                                                    (lookup "rakka:otherLang" props)
 174                           , entityContent    = content
 175                           , entityUpdateInfo = undefined
 176                           }
 177
 178       loadPageRedirect :: Rev Page
 179       loadPageRedirect
 180           = do hist    <- getNodeHistory True path
 181                content <- getFileContents path
 182
 183                let pageRev = fst $ head hist
 184                    dest    = chomp $ decodeString content
 185
 186                lastMod <- getRevisionProp "svn:date"
 187                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 188
 189                isLocked <- getRevisionProp "rakka:isLocked"
 190                            >>= return . isJust
 191
 192                return Redirection {
 193                             redirName       = name
 194                           , redirDest       = dest
 195                           , redirIsLocked   = isLocked
 196                           , redirRevision   = pageRev
 197                           , redirLastMod    = zonedTimeToUTC lastMod
 198                           , redirUpdateInfo = undefined
 199                           }
 200
 201
 202 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 203 putPageIntoRepository repos userID page
 204     = filterSvnError $
 205       do let name   = pageName page
 206              author = fromMaybe "[Rakka]" userID
 207          case pageUpdateInfo page of
 208            Just ui
 209                -> do let oldRev = uiOldRevision ui
 210                      denied <- case uiOldName ui of
 211                                  Nothing      -> checkDenial oldRev name
 212                                  Just oldName -> checkDenial oldRev oldName
 213                      if denied then
 214                          return Forbidden
 215                        else
 216                          do ret <- doReposTxn
 217                                    repos
 218                                    (uiOldRevision ui)
 219                                    author
 220                                    (Just "Automatic commit by Rakka for page update")
 221                                    $ do case uiOldName ui of
 222                                           Nothing      -> return ()
 223                                           Just oldName -> renamePage (uiOldRevision ui) oldName name
 224                                         updatePage name
 225                             case ret of
 226                               Left  _ -> return Conflict
 227                               Right _ -> return Created
 228            Nothing
 229                -> do fs  <- getRepositoryFS repos
 230                      rev <- getYoungestRev fs
 231                      ret <- doReposTxn
 232                             repos
 233                             rev
 234                             author
 235                             (Just "Automatic commit by Rakka for page creation")
 236                             $ do createPage name
 237                                  updatePage name
 238                      case ret of
 239                        Left  _ -> return Conflict
 240                        Right _ -> return Created
 241     where
 242       checkDenial :: RevNum -> PageName -> IO Bool
 243       checkDenial rev name
 244           = do fs <- getRepositoryFS repos
 245                withRevision fs rev
 246                    $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 247                         case prop of
 248                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 249                           Nothing -> return False
 250
 251       renamePage :: RevNum -> PageName -> PageName -> Txn ()
 252       renamePage oldRev oldName newName
 253           = do let oldPath = mkPagePath oldName
 254                    newPath = mkPagePath newName
 255                createParentDirectories newPath
 256                copyEntry oldRev oldPath newPath
 257                deleteEntry oldPath
 258                deleteEmptyParentDirectories oldPath
 259
 260       createPage :: PageName -> Txn ()
 261       createPage name
 262           = do let path = mkPagePath name
 263                createParentDirectories path
 264                makeFile path
 265
 266       updatePage :: PageName -> Txn ()
 267       updatePage name
 268           | isRedirect page = updatePageRedirect name
 269           | isEntity   page = updatePageEntity name
 270           | otherwise       = fail "neither redirection nor page"
 271
 272       updatePageRedirect :: PageName -> Txn ()
 273       updatePageRedirect name
 274           = do let path = mkPagePath name
 275                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 276                setNodeProp path "rakka:lang"      Nothing
 277                setNodeProp path "rakka:isTheme"   Nothing
 278                setNodeProp path "rakka:isFeed"    Nothing
 279                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
 280                setNodeProp path "rakka:isBinary"  Nothing
 281                setNodeProp path "rakka:summary"   Nothing
 282                setNodeProp path "rakka:otherLang" Nothing
 283                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 284
 285       updatePageEntity :: PageName -> Txn ()
 286       updatePageEntity name
 287           = do let path = mkPagePath name
 288                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 289                setNodeProp path "rakka:lang"      (entityLanguage page)
 290                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 291                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 292                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 293                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 294                setNodeProp path "rakka:summary"   (entitySummary page)
 295                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 296                                                    in
 297                                                      if M.null otherLang then
 298                                                          Nothing
 299                                                      else
 300                                                          Just (serializeStringPairs $ M.toList otherLang))
 301                applyTextLBS path Nothing (entityContent page)
 302
 303       encodeFlag :: Bool -> Maybe String
 304       encodeFlag True  = Just "*"
 305       encodeFlag False = Nothing
 306
 307
 308 createParentDirectories :: FilePath -> Txn ()
 309 createParentDirectories path
 310     = do let parentPath = takeDirectory path
 311          kind <- checkPath parentPath
 312          case kind of
 313            NoNode   -> do createParentDirectories parentPath
 314                           makeDirectory parentPath
 315            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 316            DirNode  -> return ()
 317
 318
 319 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 320 deletePageFromRepository repos userID name
 321     = filterSvnError $
 322       do let path = mkPagePath name
 323          fs     <- getRepositoryFS repos
 324          rev    <- getYoungestRev fs
 325          status <- withRevision fs rev
 326                    $ do exists <- isFile path
 327                         if exists then
 328                             do prop <- getNodeProp path "rakka:isLocked"
 329                                return $ case prop of
 330                                           Just _
 331                                               -> if isNothing userID then
 332                                                      -- 施錠されてゐるので匿名では駄目
 333                                                      Forbidden
 334                                                  else
 335                                                      NoContent
 336                                           Nothing
 337                                               -> NoContent
 338                           else
 339                             return NotFound
 340          when (status == NoContent)
 341              $ do doReposTxn repos
 342                              rev
 343                              "[Rakka]"
 344                              (Just "Automatic commit by Rakka for page deleting")
 345                              $ do deleteEntry path
 346                                   deleteEmptyParentDirectories path
 347                   return ()
 348          return status
 349
 350
 351 deleteEmptyParentDirectories :: FilePath -> Txn ()
 352 deleteEmptyParentDirectories path
 353     = do let parentPath = takeDirectory path
 354          contents <- getDirEntries parentPath
 355          when (null contents)
 356                   $ do deleteEntry parentPath
 357                        deleteEmptyParentDirectories parentPath
 358
 359
 360 filterSvnError :: IO a -> IO a
 361 filterSvnError f = catchDyn f rethrow
 362     where
 363       rethrow :: SvnError -> IO a
 364       rethrow err
 365           = let code = svnErrCode err
 366                 msg  = svnErrMsg  err
 367             in
 368               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg