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                           , entityIsBoring   = any ((== "rakka:isBoring") . fst) props
 135                           , entityIsBinary   = case mimeType of
 136                                                  MIMEType "text" _ _
 137                                                      -> any ((== "rakka:isBinary") . fst) props
 138                                                  _
 139                                                      -> True
 140                           , entityRevision   = pageRev
 141                           , entityLastMod    = zonedTimeToUTC lastMod
 142                           , entitySummary    = lookup "rakka:summary" props
 143                           , entityOtherLang  = fromMaybe M.empty
 144                                              $ fmap
 145                                                    (M.fromList . fromJust . deserializeStringPairs)
 146                                                    (lookup "rakka:otherLang" props)
 147                           , entityContent    = content
 148                           , entityUpdateInfo = undefined
 149                           }
 150
 151       loadPageRedirect :: Rev Page
 152       loadPageRedirect
 153           = do hist    <- getNodeHistory True path
 154                content <- getFileContents path
 155
 156                let pageRev = fst $ head hist
 157                    dest    = chomp $ decodeString content
 158
 159                lastMod <- getRevisionProp "svn:date"
 160                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 161
 162                return Redirection {
 163                             redirName       = name
 164                           , redirDest       = dest
 165                           , redirRevision   = pageRev
 166                           , redirLastMod    = zonedTimeToUTC lastMod
 167                           , redirUpdateInfo = undefined
 168                           }
 169
 170
 171 putPageIntoRepository :: Repository -> Page -> IO StatusCode
 172 putPageIntoRepository repos page
 173     = filterSvnError $
 174       do let name = pageName page
 175          ret <- case pageUpdateInfo page of
 176                   Just ui
 177                       -> doReposTxn
 178                          repos
 179                          (uiOldRevision ui)
 180                          "[Rakka]"
 181                          (Just "Automatic commit by Rakka for page update")
 182                          $ do case uiOldName ui of
 183                                 Nothing      -> return ()
 184                                 Just oldName -> renamePage (uiOldRevision ui) oldName name
 185                               updatePage name
 186                   Nothing
 187                       -> do fs  <- getRepositoryFS repos
 188                             rev <- getYoungestRev fs
 189                             doReposTxn repos
 190                                        rev
 191                                        "[Rakka]"
 192                                        (Just "Automatic commit by Rakka for page creation")
 193                                        $ do createPage name
 194                                             updatePage name
 195          case ret of
 196            Left  _ -> return Conflict
 197            Right _ -> return Created
 198     where
 199       renamePage :: RevNum -> PageName -> PageName -> Txn ()
 200       renamePage oldRev oldName newName
 201           = do let oldPath = mkPagePath oldName
 202                    newPath = mkPagePath newName
 203                createParentDirectories newPath
 204                copyEntry oldRev oldPath newPath
 205                deleteEntry oldPath
 206                deleteEmptyParentDirectories oldPath
 207
 208       createPage :: PageName -> Txn ()
 209       createPage name
 210           = do let path = mkPagePath name
 211                createParentDirectories path
 212                makeFile path
 213
 214       updatePage :: PageName -> Txn ()
 215       updatePage name
 216           | isRedirect page = updatePageRedirect name
 217           | isEntity   page = updatePageEntity name
 218           | otherwise       = fail "neither redirection nor page"
 219
 220       updatePageRedirect :: PageName -> Txn ()
 221       updatePageRedirect name
 222           = do let path = mkPagePath name
 223                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 224                setNodeProp path "rakka:lang"      Nothing
 225                setNodeProp path "rakka:isTheme"   Nothing
 226                setNodeProp path "rakka:isFeed"    Nothing
 227                setNodeProp path "rakka:isLocked"  Nothing
 228                setNodeProp path "rakka:isBoring"  Nothing
 229                setNodeProp path "rakka:isBinary"  Nothing
 230                setNodeProp path "rakka:summary"   Nothing
 231                setNodeProp path "rakka:otherLang" Nothing
 232                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 233
 234       updatePageEntity :: PageName -> Txn ()
 235       updatePageEntity name
 236           = do let path = mkPagePath name
 237                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 238                setNodeProp path "rakka:lang"      (entityLanguage page)
 239                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 240                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 241                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 242                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 243                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 244                setNodeProp path "rakka:summary"   (entitySummary page)
 245                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 246                                                    in
 247                                                      if M.null otherLang then
 248                                                          Nothing
 249                                                      else
 250                                                          Just (serializeStringPairs $ M.toList otherLang))
 251                applyTextLBS path Nothing (entityContent page)
 252
 253       encodeFlag :: Bool -> Maybe String
 254       encodeFlag True  = Just "*"
 255       encodeFlag False = Nothing
 256
 257
 258 createParentDirectories :: FilePath -> Txn ()
 259 createParentDirectories path
 260     = do let parentPath = takeDirectory path
 261          kind <- checkPath parentPath
 262          case kind of
 263            NoNode   -> do createParentDirectories parentPath
 264                           makeDirectory parentPath
 265            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 266            DirNode  -> return ()
 267
 268
 269 deletePageFromRepository :: Repository -> PageName -> IO StatusCode
 270 deletePageFromRepository repos name
 271     = filterSvnError $
 272       do let path = mkPagePath name
 273          fs     <- getRepositoryFS repos
 274          rev    <- getYoungestRev fs
 275          exists <- withRevision fs rev $ isFile path
 276          if exists then
 277              do doReposTxn repos
 278                            rev
 279                            "[Rakka]"
 280                            (Just "Automatic commit by Rakka for page deleting")
 281                            $ do deleteEntry path
 282                                 deleteEmptyParentDirectories path
 283                 return NoContent
 284            else
 285              return NotFound
 286
 287
 288 deleteEmptyParentDirectories :: FilePath -> Txn ()
 289 deleteEmptyParentDirectories path
 290     = do let parentPath = takeDirectory path
 291          contents <- getDirEntries parentPath
 292          when (null contents)
 293                   $ do deleteEntry parentPath
 294                        deleteEmptyParentDirectories parentPath
 295
 296
 297 filterSvnError :: IO a -> IO a
 298 filterSvnError f = catchDyn f rethrow
 299     where
 300       rethrow :: SvnError -> IO a
 301       rethrow err
 302           = let code = svnErrCode err
 303                 msg  = svnErrMsg  err
 304             in
 305               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg