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 ret <- doReposTxn
 230                                    repos
 231                                    (uiOldRevision ui)
 232                                    author
 233                                    (Just "Automatic commit by Rakka for page update")
 234                                    $ do case uiOldName ui of
 235                                           Nothing      -> return ()
 236                                           Just oldName -> movePage (uiOldRevision ui) oldName name
 237                                                           >>
 238                                                           moveAttachments (uiOldRevision ui) oldName name
 239                                         updatePage name
 240                             case ret of
 241                               Left  _ -> return Conflict
 242                               Right _ -> return Created
 243            Nothing
 244                -> do fs  <- getRepositoryFS repos
 245                      rev <- getYoungestRev fs
 246                      ret <- doReposTxn
 247                             repos
 248                             rev
 249                             author
 250                             (Just "Automatic commit by Rakka for page creation")
 251                             $ do createPage name
 252                                  updatePage name
 253                      case ret of
 254                        Left  _ -> return Conflict
 255                        Right _ -> return Created
 256     where
 257       checkDenial :: RevNum -> PageName -> IO Bool
 258       checkDenial rev name
 259           = do fs <- getRepositoryFS repos
 260                withRevision fs rev
 261                    $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 262                         case prop of
 263                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 264                           Nothing -> return False
 265
 266       movePage :: RevNum -> PageName -> PageName -> Txn ()
 267       movePage oldRev oldName newName
 268           = do let oldPath = mkPagePath oldName
 269                    newPath = mkPagePath newName
 270                createParentDirectories newPath
 271                copyEntry oldRev oldPath newPath
 272                deleteEntry oldPath
 273                deleteEmptyParentDirectories oldPath
 274
 275       moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
 276       moveAttachments oldRev oldName newName
 277           = do let oldPath = mkAttachmentDirPath oldName
 278                    newPath = mkAttachmentDirPath newName
 279                createParentDirectories newPath
 280                copyEntry oldRev oldPath newPath
 281                deleteEntry oldPath
 282                deleteEmptyParentDirectories oldPath
 283
 284       createPage :: PageName -> Txn ()
 285       createPage name
 286           = do let path = mkPagePath name
 287                createParentDirectories path
 288                makeFile path
 289
 290       updatePage :: PageName -> Txn ()
 291       updatePage name
 292           | isRedirect page = updatePageRedirect name
 293           | isEntity   page = updatePageEntity name
 294           | otherwise       = fail "neither redirection nor page"
 295
 296       updatePageRedirect :: PageName -> Txn ()
 297       updatePageRedirect name
 298           = do let path = mkPagePath name
 299                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 300                setNodeProp path "rakka:lang"      Nothing
 301                setNodeProp path "rakka:isTheme"   Nothing
 302                setNodeProp path "rakka:isFeed"    Nothing
 303                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
 304                setNodeProp path "rakka:isBinary"  Nothing
 305                setNodeProp path "rakka:summary"   Nothing
 306                setNodeProp path "rakka:otherLang" Nothing
 307                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 308
 309       updatePageEntity :: PageName -> Txn ()
 310       updatePageEntity name
 311           = do let path = mkPagePath name
 312                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 313                setNodeProp path "rakka:lang"      (entityLanguage page)
 314                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 315                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 316                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 317                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 318                setNodeProp path "rakka:summary"   (fmap encodeString $ entitySummary page)
 319                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 320                                                    in
 321                                                      if M.null otherLang then
 322                                                          Nothing
 323                                                      else
 324                                                          Just (encodeString $ serializeStringPairs $ M.toList otherLang))
 325                applyTextLBS path Nothing (entityContent page)
 326
 327       encodeFlag :: Bool -> Maybe String
 328       encodeFlag True  = Just "*"
 329       encodeFlag False = Nothing
 330
 331
 332 createParentDirectories :: FilePath -> Txn ()
 333 createParentDirectories path
 334     = do let parentPath = takeDirectory path
 335          kind <- checkPath parentPath
 336          case kind of
 337            NoNode   -> do createParentDirectories parentPath
 338                           makeDirectory parentPath
 339            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 340            DirNode  -> return ()
 341
 342
 343 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 344 deletePageFromRepository repos userID name
 345     = filterSvnError $
 346       do let pagePath       = mkPagePath name
 347              attachmentPath = mkAttachmentDirPath name
 348          fs     <- getRepositoryFS repos
 349          rev    <- getYoungestRev fs
 350          status <- withRevision fs rev
 351                    $ do exists <- isFile pagePath
 352                         if exists then
 353                             do prop <- getNodeProp pagePath "rakka:isLocked"
 354                                return $ case prop of
 355                                           Just _
 356                                               -> if isNothing userID then
 357                                                      -- 施錠されてゐるので匿名では駄目
 358                                                      Forbidden
 359                                                  else
 360                                                      NoContent
 361                                           Nothing
 362                                               -> NoContent
 363                           else
 364                             return NotFound
 365          when (status == NoContent)
 366              $ do doReposTxn repos
 367                              rev
 368                              "[Rakka]"
 369                              (Just "Automatic commit by Rakka for page deleting")
 370                              $ do deleteEntry pagePath
 371                                   deleteEmptyParentDirectories pagePath
 372
 373                                   attachmentExists <- isDirectory attachmentPath
 374                                   when attachmentExists
 375                                       $ do deleteEntry attachmentPath
 376                                            deleteEmptyParentDirectories attachmentPath
 377                   return ()
 378          return status
 379
 380
 381 deleteEmptyParentDirectories :: FilePath -> Txn ()
 382 deleteEmptyParentDirectories path
 383     = do let parentPath = takeDirectory path
 384          contents <- getDirEntries parentPath
 385          when (null contents)
 386                   $ do deleteEntry parentPath
 387                        deleteEmptyParentDirectories parentPath
 388
 389
 390 loadAttachmentInRepository :: forall a. Attachment a =>
 391                               Repository
 392                            -> PageName
 393                            -> String
 394                            -> Maybe RevNum
 395                            -> IO (Maybe a)
 396 loadAttachmentInRepository repos pName aName rev
 397     = do fs   <- getRepositoryFS repos
 398          rev' <- case rev of
 399                    Nothing -> getYoungestRev fs
 400                    Just r  -> return r
 401          withRevision fs rev'
 402              $ do exists <- isFile path
 403                   if exists then
 404                       return . Just =<< loadAttachment'
 405                     else
 406                       return Nothing
 407     where
 408       path :: FilePath
 409       path = mkAttachmentPath pName aName
 410
 411       loadAttachment' :: Rev a
 412       loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
 413
 414
 415 putAttachmentIntoRepository :: Attachment a =>
 416                                Repository
 417                             -> Maybe String
 418                             -> Maybe RevNum
 419                             -> PageName
 420                             -> String
 421                             -> a
 422                             -> IO StatusCode
 423 putAttachmentIntoRepository repos userID oldRev pName aName attachment
 424     = filterSvnError $
 425       do let author = fromMaybe "[Rakka]" userID
 426              path   = mkAttachmentPath pName aName
 427          fs      <- getRepositoryFS repos
 428          oldRev' <- case oldRev of
 429                       Nothing -> getYoungestRev fs
 430                       Just r  -> return r
 431          ret <- doReposTxn
 432                 repos
 433                 oldRev'
 434                 author
 435                 (Just "Automatic commit by Rakka for putting attachment")
 436                 $ do exists <- isFile path
 437                      unless exists
 438                          $ do createParentDirectories path
 439                               makeFile path
 440                      applyText path Nothing (serializeToString attachment)
 441          case ret of
 442            Left  _ -> return Conflict
 443            Right _ -> return NoContent
 444
 445
 446 filterSvnError :: IO a -> IO a
 447 filterSvnError f = catchDyn f rethrow
 448     where
 449       rethrow :: SvnError -> IO a
 450       rethrow err
 451           = let code = svnErrCode err
 452                 msg  = svnErrMsg  err
 453             in
 454               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg