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 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 :: PageName -> PageName -> Txn ()
 200       renamePage oldName newName
 201           = fail "FIXME: renamePage: not implemented yet"
 202
 203       createPage :: PageName -> Txn ()
 204       createPage name
 205           = do let path = mkPagePath name
 206                createParentDirectories path
 207                makeFile path
 208
 209       createParentDirectories :: FilePath -> Txn ()
 210       createParentDirectories path
 211           = do let parentPath = takeDirectory path
 212                kind <- checkPath parentPath
 213                case kind of
 214                  NoNode   -> do createParentDirectories parentPath
 215                                 makeDirectory parentPath
 216                  FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 217                  DirNode  -> return ()
 218
 219       updatePage :: PageName -> Txn ()
 220       updatePage name
 221           | isRedirect page = updatePageRedirect name
 222           | isEntity   page = updatePageEntity name
 223           | otherwise       = fail "neither redirection nor page"
 224
 225       updatePageRedirect :: PageName -> Txn ()
 226       updatePageRedirect name
 227           = do let path = mkPagePath name
 228                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 229                setNodeProp path "rakka:lang"      Nothing
 230                setNodeProp path "rakka:isTheme"   Nothing
 231                setNodeProp path "rakka:isFeed"    Nothing
 232                setNodeProp path "rakka:isLocked"  Nothing
 233                setNodeProp path "rakka:isBoring"  Nothing
 234                setNodeProp path "rakka:isBinary"  Nothing
 235                setNodeProp path "rakka:summary"   Nothing
 236                setNodeProp path "rakka:otherLang" Nothing
 237                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 238
 239       updatePageEntity :: PageName -> Txn ()
 240       updatePageEntity name
 241           = do let path = mkPagePath name
 242                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 243                setNodeProp path "rakka:lang"      (entityLanguage page)
 244                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 245                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 246                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 247                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 248                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 249                setNodeProp path "rakka:summary"   (entitySummary page)
 250                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 251                                                    in
 252                                                      if M.null otherLang then
 253                                                          Nothing
 254                                                      else
 255                                                          Just (serializeStringPairs $ M.toList otherLang))
 256                applyTextLBS path Nothing (entityContent page)
 257
 258       encodeFlag :: Bool -> Maybe String
 259       encodeFlag True  = Just "*"
 260       encodeFlag False = Nothing
 261
 262
 263 deletePageFromRepository :: Repository -> PageName -> IO StatusCode
 264 deletePageFromRepository repos name
 265     = filterSvnError $
 266       do let path = mkPagePath name
 267          fs     <- getRepositoryFS repos
 268          rev    <- getYoungestRev fs
 269          exists <- withRevision fs rev $ isFile path
 270          if exists then
 271              do doReposTxn repos
 272                            rev
 273                            "[Rakka]"
 274                            (Just "Automatic commit by Rakka for page deleting")
 275                            $ do deleteEntry path
 276                                 deleteEmptyParentDirectories path
 277                 return NoContent
 278            else
 279              return NotFound
 280     where
 281       deleteEmptyParentDirectories :: FilePath -> Txn ()
 282       deleteEmptyParentDirectories path
 283           = do let parentPath = takeDirectory path
 284                contents <- getDirEntries parentPath
 285                when (null contents)
 286                         $ do deleteEntry parentPath
 287                              deleteEmptyParentDirectories parentPath
 288
 289
 290 filterSvnError :: IO a -> IO a
 291 filterSvnError f = catchDyn f rethrow
 292     where
 293       rethrow :: SvnError -> IO a
 294       rethrow err
 295           = let code = svnErrCode err
 296                 msg  = svnErrMsg  err
 297             in
 298               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg