Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , findChangedPagesAtRevision
   4     , loadPageInRepository
   5     , putPageIntoRepository
   6     )
   7     where
   8
   9 import           Codec.Binary.UTF8.String
  10 import           Control.Exception
  11 import           Control.Monad
  12 import           Data.List
  13 import qualified Data.Map as M
  14 import           Data.Maybe
  15 import           Data.Set (Set)
  16 import qualified Data.Set as S hiding (Set)
  17 import           Data.Time
  18 import           Network.HTTP.Lucu hiding (redirect)
  19 import           Rakka.Page
  20 import           Rakka.SystemConfig
  21 import           Rakka.Utils
  22 import           Rakka.W3CDateTime
  23 import           Subversion.Error
  24 import           Subversion.FileSystem
  25 import           Subversion.FileSystem.DirEntry
  26 import           Subversion.FileSystem.Revision
  27 import           Subversion.FileSystem.Root
  28 import           Subversion.FileSystem.Transaction
  29 import           Subversion.Repository
  30 import           Subversion.Types
  31 import           System.FilePath.Posix
  32
  33
  34 mkPagePath :: PageName -> FilePath
  35 mkPagePath name
  36     = "/pages" </> encodePageName name <.> "page"
  37
  38
  39 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  40 findAllPagesInRevision repos rev
  41     = do fs <- getRepositoryFS repos
  42          withRevision fs rev
  43              $ do exists <- isDirectory root
  44                   if exists then
  45                       traverse root
  46                     else
  47                       return S.empty
  48     where
  49       root :: FilePath
  50       root = "/pages"
  51
  52       traverse :: FilePath -> Rev (Set PageName)
  53       traverse dir
  54           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  55
  56       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  57       traverse' dir entry
  58           = let path = dir </> entName entry
  59             in
  60               do kind <- checkPath path
  61                  case kind of
  62                    NoNode   -> return S.empty
  63                    FileNode -> return $ S.singleton (decodePath path)
  64                    DirNode  -> traverse path
  65
  66       decodePath :: FilePath -> PageName
  67       decodePath = decodePageName . makeRelative root . dropExtension
  68
  69
  70 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
  71 findChangedPagesAtRevision repos rev
  72     = do fs <- getRepositoryFS repos
  73          withRevision fs rev
  74              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
  75     where
  76       accumulatePages :: Set PageName -> FilePath -> Set PageName
  77       accumulatePages s path
  78           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
  79               = let encoded = makeRelative "/pages" $ dropExtension path
  80                     name    = decodePageName encoded
  81                 in
  82                   S.insert name s
  83           | otherwise
  84               = s
  85
  86
  87 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  88 loadPageInRepository repos name rev
  89     = do fs   <- getRepositoryFS repos
  90          rev' <- case rev of
  91                    Nothing -> getYoungestRev fs
  92                    Just r  -> return r
  93          withRevision fs rev'
  94              $ do exists <- isFile path
  95                   case exists of
  96                     True
  97                         -> return . Just =<< loadPage'
  98                     False
  99                         -> return Nothing
 100     where
 101       path :: FilePath
 102       path = mkPagePath name
 103
 104       loadPage' :: Rev Page
 105       loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
 106                      case mType of
 107                        Just (MIMEType "application" "x-rakka-redirection" _)
 108                            -> loadPageRedirect
 109                        _
 110                            -> loadPageEntity
 111
 112       loadPageEntity :: Rev Page
 113       loadPageEntity
 114           = do props   <- getNodePropList path
 115                hist    <- getNodeHistory True path
 116                content <- getFileContentsLBS path
 117
 118                let pageRev  = fst $ head hist
 119                    mimeType = read
 120                               $ fromMaybe "text/x-rakka"
 121                               $ fmap chomp (lookup "svn:mime-type" props)
 122
 123                lastMod <- getRevisionProp "svn:date"
 124                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 125
 126                return Entity {
 127                             entityName       = name
 128                           , entityType       = mimeType
 129                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 130                           , entityFileName   = fmap chomp (lookup "rakka:fileName" 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:fileName"  Nothing
 231                setNodeProp path "rakka:isTheme"   Nothing
 232                setNodeProp path "rakka:isFeed"    Nothing
 233                setNodeProp path "rakka:isLocked"  Nothing
 234                setNodeProp path "rakka:isBoring"  Nothing
 235                setNodeProp path "rakka:isBinary"  Nothing
 236                setNodeProp path "rakka:summary"   Nothing
 237                setNodeProp path "rakka:otherLang" Nothing
 238                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 239
 240       updatePageEntity :: PageName -> Txn ()
 241       updatePageEntity name
 242           = do let path = mkPagePath name
 243                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 244                setNodeProp path "rakka:lang"      (entityLanguage page)
 245                setNodeProp path "rakka:fileName"  (entityFileName page)
 246                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 247                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 248                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 249                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 250                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 251                setNodeProp path "rakka:summary"   (entitySummary page)
 252                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 253                                                    in
 254                                                      if M.null otherLang then
 255                                                          Nothing
 256                                                      else
 257                                                          Just (serializeStringPairs $ M.toList otherLang))
 258                applyTextLBS path Nothing (entityContent page)
 259
 260       encodeFlag :: Bool -> Maybe String
 261       encodeFlag True  = Just "*"
 262       encodeFlag False = Nothing
 263
 264
 265 filterSvnError :: IO a -> IO a
 266 filterSvnError f = catchDyn f rethrow
 267     where
 268       rethrow :: SvnError -> IO a
 269       rethrow err
 270           = let code = svnErrCode err
 271                 msg  = svnErrMsg  err
 272             in
 273               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg