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                           , 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
 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 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 :: PageName -> PageName -> Txn ()
 199       renamePage oldName newName
 200           = fail "FIXME: renamePage: not implemented yet"
 201
 202       createPage :: PageName -> Txn ()
 203       createPage name
 204           = do let path = mkPagePath name
 205                createParentDirectories path
 206                makeFile path
 207
 208       createParentDirectories :: FilePath -> Txn ()
 209       createParentDirectories path
 210           = do let parentPath = takeDirectory path
 211                kind <- checkPath parentPath
 212                case kind of
 213                  NoNode   -> do createParentDirectories parentPath
 214                                 makeDirectory parentPath
 215                  FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 216                  DirNode  -> return ()
 217
 218       updatePage :: PageName -> Txn ()
 219       updatePage name
 220           | isRedirect page = updatePageRedirect name
 221           | isEntity   page = updatePageEntity name
 222           | otherwise       = fail "neither redirection nor page"
 223
 224       updatePageRedirect :: PageName -> Txn ()
 225       updatePageRedirect name
 226           = do let path = mkPagePath name
 227                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 228                setNodeProp path "rakka:lang"      Nothing
 229                setNodeProp path "rakka:isTheme"   Nothing
 230                setNodeProp path "rakka:isFeed"    Nothing
 231                setNodeProp path "rakka:isLocked"  Nothing
 232                setNodeProp path "rakka:isBoring"  Nothing
 233                setNodeProp path "rakka:isBinary"  Nothing
 234                setNodeProp path "rakka:summary"   Nothing
 235                setNodeProp path "rakka:otherLang" Nothing
 236                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 237
 238       updatePageEntity :: PageName -> Txn ()
 239       updatePageEntity name
 240           = do let path = mkPagePath name
 241                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 242                setNodeProp path "rakka:lang"      (entityLanguage page)
 243                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 244                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 245                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 246                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 247                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 248                setNodeProp path "rakka:summary"   (entitySummary page)
 249                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 250                                                    in
 251                                                      if M.null otherLang then
 252                                                          Nothing
 253                                                      else
 254                                                          Just (serializeStringPairs $ M.toList otherLang))
 255                applyTextLBS path Nothing (entityContent page)
 256
 257       encodeFlag :: Bool -> Maybe String
 258       encodeFlag True  = Just "*"
 259       encodeFlag False = Nothing
 260
 261
 262 filterSvnError :: IO a -> IO a
 263 filterSvnError f = catchDyn f rethrow
 264     where
 265       rethrow :: SvnError -> IO a
 266       rethrow err
 267           = let code = svnErrCode err
 268                 msg  = svnErrMsg  err
 269             in
 270               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg