Rakka/Storage/Repos.hs

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