Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , findChangedPagesAtRevision
   4     , loadPageInRepository
   5     , putPageIntoRepository
   6     )
   7     where
   8
   9 import           Control.Exception
  10 import           Control.Monad
  11 import           Data.List
  12 import qualified Data.Map as M
  13 import           Data.Maybe
  14 import           Data.Set (Set)
  15 import qualified Data.Set as S hiding (Set)
  16 import           Data.Time
  17 import           Network.HTTP.Lucu hiding (redirect)
  18 import           Rakka.Page
  19 import           Rakka.SystemConfig
  20 import           Rakka.Utils
  21 import           Rakka.W3CDateTime
  22 import           Subversion.Error
  23 import           Subversion.FileSystem
  24 import           Subversion.FileSystem.DirEntry
  25 import           Subversion.FileSystem.Revision
  26 import           Subversion.FileSystem.Root
  27 import           Subversion.FileSystem.Transaction
  28 import           Subversion.Repository
  29 import           Subversion.Types
  30 import           System.FilePath.Posix
  31
  32
  33 mkPagePath :: PageName -> FilePath
  34 mkPagePath name
  35     = "/pages" </> encodePageName name <.> "page"
  36
  37
  38 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  39 findAllPagesInRevision repos rev
  40     = do fs <- getRepositoryFS repos
  41          withRevision fs rev
  42              $ do exists <- isDirectory root
  43                   if exists then
  44                       traverse root
  45                     else
  46                       return S.empty
  47     where
  48       root :: FilePath
  49       root = "/pages"
  50
  51       traverse :: FilePath -> Rev (Set PageName)
  52       traverse dir
  53           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  54
  55       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  56       traverse' dir entry
  57           = let path = dir </> entName entry
  58             in
  59               do kind <- checkPath path
  60                  case kind of
  61                    NoNode   -> return S.empty
  62                    FileNode -> return $ S.singleton (decodePath path)
  63                    DirNode  -> traverse path
  64
  65       decodePath :: FilePath -> PageName
  66       decodePath = decodePageName . makeRelative root . dropExtension
  67
  68
  69 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
  70 findChangedPagesAtRevision repos rev
  71     = do fs <- getRepositoryFS repos
  72          withRevision fs rev
  73              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
  74     where
  75       accumulatePages :: Set PageName -> FilePath -> Set PageName
  76       accumulatePages s path
  77           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
  78               = let encoded = makeRelative "/pages" $ dropExtension path
  79                     name    = decodePageName encoded
  80                 in
  81                   S.insert name s
  82           | otherwise
  83               = s
  84
  85
  86 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  87 loadPageInRepository repos name rev
  88     = do fs   <- getRepositoryFS repos
  89          rev' <- case rev of
  90                    Nothing -> getYoungestRev fs
  91                    Just r  -> return r
  92          withRevision fs rev'
  93              $ do exists <- isFile path
  94                   case exists of
  95                     True
  96                         -> return . Just =<< loadPage'
  97                     False
  98                         -> return Nothing
  99     where
 100       path :: FilePath
 101       path = mkPagePath name
 102
 103       loadPage' :: Rev Page
 104       loadPage' = do redirect <- getNodeProp path "rakka:redirect"
 105                      case redirect of
 106                        Nothing
 107                            -> loadPageEntity
 108                        Just _
 109                            -> loadPageRedirect
 110
 111       loadPageEntity :: Rev Page
 112       loadPageEntity
 113           = do props   <- getNodePropList path
 114                hist    <- getNodeHistory True path
 115                content <- getFileContentsLBS path
 116
 117                let pageRev  = fst $ head hist
 118                    mimeType = read
 119                               $ fromMaybe "text/x-rakka"
 120                               $ fmap chomp (lookup "svn:mime-type" props)
 121
 122                lastMod <- getRevisionProp "svn:date"
 123                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 124
 125                return Entity {
 126                             entityName       = name
 127                           , entityType       = mimeType
 128                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 129                           , entityFileName   = fmap chomp (lookup "rakka:fileName" props)
 130                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 131                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 132                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 133                           , entityIsBoring   = any ((== "rakka:isBoring") . 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 = fail "FIXME: loadPageRedirect: not implemented"
 152
 153
 154 putPageIntoRepository :: Repository -> Page -> IO StatusCode
 155 putPageIntoRepository repos page
 156     = filterSvnError $
 157       do let name = pageName page
 158          ret <- case pageUpdateInfo page of
 159                   Just ui
 160                       -> doReposTxn
 161                          repos
 162                          (uiOldRevision ui)
 163                          "[Rakka]"
 164                          (Just "Automatic commit by Rakka for page update")
 165                          $ do case uiOldName ui of
 166                                 Nothing      -> return ()
 167                                 Just oldName -> renamePage oldName name
 168                               updatePage name
 169                   Nothing
 170                       -> do fs  <- getRepositoryFS repos
 171                             rev <- getYoungestRev fs
 172                             doReposTxn repos
 173                                          rev
 174                                          "[Rakka]"
 175                                          (Just "Automatic commit by Rakka for page creation")
 176                                          $ do createPage name
 177                                               updatePage name
 178          case ret of
 179            Left  _ -> return Conflict
 180            Right _ -> return Created
 181     where
 182       renamePage :: PageName -> PageName -> Txn ()
 183       renamePage oldName newName
 184           = fail "FIXME: renamePage: not implemented yet"
 185
 186       createPage :: PageName -> Txn ()
 187       createPage name
 188           = do let path = mkPagePath name
 189                createParentDirectories path
 190                makeFile path
 191
 192       createParentDirectories :: FilePath -> Txn ()
 193       createParentDirectories path
 194           = do let parentPath = takeDirectory path
 195                kind <- checkPath parentPath
 196                case kind of
 197                  NoNode   -> do createParentDirectories parentPath
 198                                 makeDirectory parentPath
 199                  FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 200                  DirNode  -> return ()
 201
 202       updatePage :: PageName -> Txn ()
 203       updatePage name
 204           | isRedirect page = updatePageRedirect name
 205           | isEntity   page = updatePageEntity name
 206           | otherwise       = fail "neither redirection nor page"
 207
 208       updatePageRedirect :: PageName -> Txn ()
 209       updatePageRedirect name
 210           = fail "FIXME: updatePageRedirect: not implemented yet"
 211
 212       updatePageEntity :: PageName -> Txn ()
 213       updatePageEntity name
 214           = do let path = mkPagePath name
 215                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 216                setNodeProp path "rakka:lang"      (entityLanguage page)
 217                setNodeProp path "rakka:fileName"  (entityFileName page)
 218                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 219                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 220                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 221                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 222                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 223                setNodeProp path "rakka:summary"   (entitySummary page)
 224                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 225                                                    in
 226                                                      if M.null otherLang then
 227                                                          Nothing
 228                                                      else
 229                                                          Just (serializeStringPairs $ M.toList otherLang))
 230                applyTextLBS path Nothing (entityContent page)
 231
 232       encodeFlag :: Bool -> Maybe String
 233       encodeFlag True  = Just "*\n"
 234       encodeFlag False = Nothing
 235
 236
 237 filterSvnError :: IO a -> IO a
 238 filterSvnError f = catchDyn f rethrow
 239     where
 240       rethrow :: SvnError -> IO a
 241       rethrow err
 242           = let code = svnErrCode err
 243                 msg  = svnErrMsg  err
 244             in
 245               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg