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
  14 import           Codec.Binary.UTF8.String
  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 qualified Data.Time.W3C as W3C
  23 import           Network.HTTP.Lucu hiding (redirect)
  24 import           Rakka.Attachment
  25 import           Rakka.Page
  26 import           Rakka.SystemConfig
  27 import           Rakka.Utils
  28 import           Subversion.FileSystem
  29 import           Subversion.FileSystem.DirEntry
  30 import           Subversion.FileSystem.Revision
  31 import           Subversion.FileSystem.Root
  32 import           Subversion.FileSystem.Transaction
  33 import           Subversion.Repository
  34 import           Subversion.Types
  35 import           System.FilePath.Posix
  36
  37
  38 mkPagePath :: PageName -> FilePath
  39 mkPagePath name
  40     = "/pages" </> encodePageName name <.> "page"
  41
  42
  43 mkDirPath :: PageName -> FilePath
  44 mkDirPath dir
  45     = "/pages" </> encodePageName dir
  46
  47
  48 mkAttachmentPath :: PageName -> String -> FilePath
  49 mkAttachmentPath pName aName
  50     = "/attachments" </> encodePageName pName <.> "page" </> aName
  51
  52
  53 mkAttachmentDirPath :: PageName -> FilePath
  54 mkAttachmentDirPath pName
  55     = "/attachments" </> encodePageName pName <.> "page"
  56
  57
  58 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  59 findAllPagesInRevision repos rev
  60     = do fs <- getRepositoryFS repos
  61          withRevision fs rev
  62              $ do exists <- isDirectory root
  63                   if exists then
  64                       traverse root
  65                     else
  66                       return S.empty
  67     where
  68       root :: FilePath
  69       root = "/pages"
  70
  71       traverse :: FilePath -> Rev (Set PageName)
  72       traverse dir
  73           = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
  74
  75       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  76       traverse' dir entry
  77           = let path = dir </> entName entry
  78             in
  79               do kind <- checkPath path
  80                  case kind of
  81                    NoNode   -> return S.empty
  82                    FileNode -> return $ S.singleton (decodePath path)
  83                    DirNode  -> traverse path
  84
  85       decodePath :: FilePath -> PageName
  86       decodePath = decodePageName . makeRelative root . dropExtension
  87
  88
  89 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
  90 getDirContentsInRevision repos dir rev
  91     = do fs   <- getRepositoryFS repos
  92          rev' <- case rev of
  93                    Nothing -> getYoungestRev fs
  94                    Just r  -> return r
  95          withRevision fs rev'
  96              $ do exists <- isDirectory path
  97                   if exists then
  98                       return . S.fromList =<< getDir'
  99                     else
 100                       return S.empty
 101     where
 102       path :: FilePath
 103       path = mkDirPath dir
 104
 105       getDir' :: Rev [PageName]
 106       getDir' = liftM (map entToName) (getDirEntries path)
 107
 108       entToName :: DirEntry -> PageName
 109       entToName = (dir </>) . decodePageName . dropExtension . entName
 110
 111
 112 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
 113 findChangedPagesAtRevision repos rev
 114     = do fs <- getRepositoryFS repos
 115          withRevision fs rev
 116              $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
 117     where
 118       accumulatePages :: Set PageName -> FilePath -> Set PageName
 119       accumulatePages s path
 120           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
 121               = let encoded = makeRelative "/pages" $ dropExtension path
 122                     name    = decodePageName encoded
 123                 in
 124                   S.insert name s
 125           | otherwise
 126               = s
 127
 128
 129 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
 130 loadPageInRepository repos name rev
 131     = do fs   <- getRepositoryFS repos
 132          rev' <- case rev of
 133                    Nothing -> getYoungestRev fs
 134                    Just r  -> return r
 135          withRevision fs rev'
 136              $ do exists <- isFile path
 137                   if exists then
 138                       return . Just =<< loadPage' fs
 139                     else
 140                       return Nothing
 141     where
 142       path :: FilePath
 143       path = mkPagePath name
 144
 145       loadPage' :: FileSystem -> Rev Page
 146       loadPage' fs
 147           = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
 148                case mType of
 149                  Just (MIMEType "application" "x-rakka-redirection" _)
 150                      -> loadPageRedirect fs
 151                  _
 152                      -> loadPageEntity fs
 153
 154       loadPageEntity :: FileSystem -> Rev Page
 155       loadPageEntity fs
 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 <- unsafeIOToFS $
 166                           liftM (fromJust . W3C.parse . chomp . fromJust)
 167                                 (getRevisionProp' fs pageRev "svn:date")
 168
 169                return Entity {
 170                             entityName       = name
 171                           , entityType       = mimeType
 172                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 173                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 174                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 175                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 176                           , entityIsBinary   = case mimeType of
 177                                                  MIMEType "text" _ _
 178                                                      -> any ((== "rakka:isBinary") . fst) props
 179                                                  _
 180                                                      -> True
 181                           , entityRevision   = pageRev
 182                           , entityLastMod    = zonedTimeToUTC lastMod
 183                           , entitySummary    = fmap decodeString (lookup "rakka:summary" props)
 184                           , entityOtherLang  = fromMaybe M.empty
 185                                              $ fmap
 186                                                    (M.fromList . fromJust . deserializeStringPairs . decodeString)
 187                                                    (lookup "rakka:otherLang" props)
 188                           , entityContent    = content
 189                           , entityUpdateInfo = undefined
 190                           }
 191
 192       loadPageRedirect :: FileSystem -> Rev Page
 193       loadPageRedirect fs
 194           = do hist    <- getNodeHistory True path
 195                content <- getFileContents path
 196
 197                let pageRev = fst $ head hist
 198                    dest    = chomp $ decodeString content
 199
 200                lastMod <- unsafeIOToFS $
 201                           liftM (fromJust . W3C.parse . chomp . fromJust)
 202                                 (getRevisionProp' fs pageRev "svn:date")
 203
 204                isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
 205
 206                return Redirection {
 207                             redirName       = name
 208                           , redirDest       = dest
 209                           , redirIsLocked   = isLocked
 210                           , redirRevision   = pageRev
 211                           , redirLastMod    = zonedTimeToUTC lastMod
 212                           , redirUpdateInfo = undefined
 213                           }
 214
 215
 216 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 217 putPageIntoRepository repos userID page
 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     = do let pagePath       = mkPagePath name
 359              attachmentPath = mkAttachmentDirPath name
 360          fs     <- getRepositoryFS repos
 361          rev    <- getYoungestRev fs
 362          status <- withRevision fs rev
 363                    $ do exists <- isFile pagePath
 364                         if exists then
 365                             do prop <- getNodeProp pagePath "rakka:isLocked"
 366                                return $ case prop of
 367                                           Just _
 368                                               -> if isNothing userID then
 369                                                      -- 施錠されてゐるので匿名では駄目
 370                                                      Forbidden
 371                                                  else
 372                                                      NoContent
 373                                           Nothing
 374                                               -> NoContent
 375                           else
 376                             return NotFound
 377          when (status == NoContent)
 378              $ ( (doReposTxn repos
 379                              rev
 380                              "[Rakka]"
 381                              (Just "Automatic commit by Rakka for page deleting")
 382                              $ do deleteEntry pagePath
 383                                   deleteEmptyParentDirectories pagePath
 384
 385                                   attachmentExists <- isDirectory attachmentPath
 386                                   when attachmentExists
 387                                       $ do deleteEntry attachmentPath
 388                                            deleteEmptyParentDirectories attachmentPath)
 389                  >> return () )
 390          return status
 391
 392
 393 deleteEmptyParentDirectories :: FilePath -> Txn ()
 394 deleteEmptyParentDirectories path
 395     = do let parentPath = takeDirectory path
 396          contents <- getDirEntries parentPath
 397          when (null contents)
 398                   $ do deleteEntry parentPath
 399                        deleteEmptyParentDirectories parentPath
 400
 401
 402 loadAttachmentInRepository :: forall a. Attachment a =>
 403                               Repository
 404                            -> PageName
 405                            -> String
 406                            -> Maybe RevNum
 407                            -> IO (Maybe a)
 408 loadAttachmentInRepository repos pName aName rev
 409     = do fs   <- getRepositoryFS repos
 410          rev' <- case rev of
 411                    Nothing -> getYoungestRev fs
 412                    Just r  -> return r
 413          withRevision fs rev'
 414              $ do exists <- isFile path
 415                   if exists then
 416                       return . Just =<< loadAttachment'
 417                     else
 418                       return Nothing
 419     where
 420       path :: FilePath
 421       path = mkAttachmentPath pName aName
 422
 423       loadAttachment' :: Rev a
 424       loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
 425
 426
 427 putAttachmentIntoRepository :: Attachment a =>
 428                                Repository
 429                             -> Maybe String
 430                             -> Maybe RevNum
 431                             -> PageName
 432                             -> String
 433                             -> a
 434                             -> IO StatusCode
 435 putAttachmentIntoRepository repos userID oldRev pName aName attachment
 436     = do let author = fromMaybe "[Rakka]" userID
 437              path   = mkAttachmentPath pName aName
 438          fs      <- getRepositoryFS repos
 439          oldRev' <- case oldRev of
 440                       Nothing -> getYoungestRev fs
 441                       Just r  -> return r
 442          ret <- doReposTxn
 443                 repos
 444                 oldRev'
 445                 author
 446                 (Just "Automatic commit by Rakka for putting attachment")
 447                 $ do exists <- isFile path
 448                      unless exists
 449                          $ do createParentDirectories path
 450                               makeFile path
 451                      applyText path Nothing (encodeString $ serializeToString attachment)
 452          case ret of
 453            Left  _ -> return Conflict
 454            Right _ -> return NoContent