Rakka/Storage/Repos.hs

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