Rakka/Storage/Repos.hs

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