1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , findChangedPagesAtRevision
5 , putPageIntoRepository
6 , deletePageFromRepository
10 import Codec.Binary.UTF8.String
11 import Control.Exception
14 import qualified Data.Map as M
17 import qualified Data.Set as S hiding (Set)
19 import Network.HTTP.Lucu hiding (redirect)
21 import Rakka.SystemConfig
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
35 mkPagePath :: PageName -> FilePath
37 = "/pages" </> encodePageName name <.> "page"
40 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
41 findAllPagesInRevision repos rev
42 = do fs <- getRepositoryFS repos
44 $ do exists <- isDirectory root
53 traverse :: FilePath -> Rev (Set PageName)
55 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
57 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
59 = let path = dir </> entName entry
61 do kind <- checkPath path
63 NoNode -> return S.empty
64 FileNode -> return $ S.singleton (decodePath path)
65 DirNode -> traverse path
67 decodePath :: FilePath -> PageName
68 decodePath = decodePageName . makeRelative root . dropExtension
71 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
72 findChangedPagesAtRevision repos rev
73 = do fs <- getRepositoryFS repos
75 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
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
88 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
89 loadPageInRepository repos name rev
90 = do fs <- getRepositoryFS repos
92 Nothing -> getYoungestRev fs
95 $ do exists <- isFile path
98 -> return . Just =<< loadPage'
103 path = mkPagePath name
105 loadPage' :: Rev Page
106 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
108 Just (MIMEType "application" "x-rakka-redirection" _)
113 loadPageEntity :: Rev Page
115 = do props <- getNodePropList path
116 hist <- getNodeHistory True path
117 content <- getFileContentsLBS path
119 let pageRev = fst $ head hist
121 $ fromMaybe "text/x-rakka"
122 $ fmap chomp (lookup "svn:mime-type" props)
124 lastMod <- getRevisionProp "svn:date"
125 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
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 , entityIsBinary = case mimeType of
136 -> any ((== "rakka:isBinary") . fst) props
139 , entityRevision = pageRev
140 , entityLastMod = zonedTimeToUTC lastMod
141 , entitySummary = lookup "rakka:summary" props
142 , entityOtherLang = fromMaybe M.empty
144 (M.fromList . fromJust . deserializeStringPairs)
145 (lookup "rakka:otherLang" props)
146 , entityContent = content
147 , entityUpdateInfo = undefined
150 loadPageRedirect :: Rev Page
152 = do hist <- getNodeHistory True path
153 content <- getFileContents path
155 let pageRev = fst $ head hist
156 dest = chomp $ decodeString content
158 lastMod <- getRevisionProp "svn:date"
159 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
161 isLocked <- getRevisionProp "rakka:isLocked"
167 , redirIsLocked = isLocked
168 , redirRevision = pageRev
169 , redirLastMod = zonedTimeToUTC lastMod
170 , redirUpdateInfo = undefined
174 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
175 putPageIntoRepository repos userID page
177 do let name = pageName page
178 author = fromMaybe "[Rakka]" userID
179 case pageUpdateInfo page of
181 -> do let oldRev = uiOldRevision ui
182 denied <- case uiOldName ui of
183 Nothing -> checkDenial oldRev name
184 Just oldName -> checkDenial oldRev oldName
192 (Just "Automatic commit by Rakka for page update")
193 $ do case uiOldName ui of
195 Just oldName -> renamePage (uiOldRevision ui) oldName name
198 Left _ -> return Conflict
199 Right _ -> return Created
201 -> do fs <- getRepositoryFS repos
202 rev <- getYoungestRev fs
207 (Just "Automatic commit by Rakka for page creation")
211 Left _ -> return Conflict
212 Right _ -> return Created
214 checkDenial :: RevNum -> PageName -> IO Bool
216 = do fs <- getRepositoryFS repos
218 $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
220 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
221 Nothing -> return False
223 renamePage :: RevNum -> PageName -> PageName -> Txn ()
224 renamePage oldRev oldName newName
225 = do let oldPath = mkPagePath oldName
226 newPath = mkPagePath newName
227 createParentDirectories newPath
228 copyEntry oldRev oldPath newPath
230 deleteEmptyParentDirectories oldPath
232 createPage :: PageName -> Txn ()
234 = do let path = mkPagePath name
235 createParentDirectories path
238 updatePage :: PageName -> Txn ()
240 | isRedirect page = updatePageRedirect name
241 | isEntity page = updatePageEntity name
242 | otherwise = fail "neither redirection nor page"
244 updatePageRedirect :: PageName -> Txn ()
245 updatePageRedirect name
246 = do let path = mkPagePath name
247 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
248 setNodeProp path "rakka:lang" Nothing
249 setNodeProp path "rakka:isTheme" Nothing
250 setNodeProp path "rakka:isFeed" Nothing
251 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
252 setNodeProp path "rakka:isBinary" Nothing
253 setNodeProp path "rakka:summary" Nothing
254 setNodeProp path "rakka:otherLang" Nothing
255 applyText path Nothing (encodeString (redirDest page) ++ "\n")
257 updatePageEntity :: PageName -> Txn ()
258 updatePageEntity name
259 = do let path = mkPagePath name
260 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
261 setNodeProp path "rakka:lang" (entityLanguage page)
262 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
263 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
264 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
265 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
266 setNodeProp path "rakka:summary" (entitySummary page)
267 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
269 if M.null otherLang then
272 Just (serializeStringPairs $ M.toList otherLang))
273 applyTextLBS path Nothing (entityContent page)
275 encodeFlag :: Bool -> Maybe String
276 encodeFlag True = Just "*"
277 encodeFlag False = Nothing
280 createParentDirectories :: FilePath -> Txn ()
281 createParentDirectories path
282 = do let parentPath = takeDirectory path
283 kind <- checkPath parentPath
285 NoNode -> do createParentDirectories parentPath
286 makeDirectory parentPath
287 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
291 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
292 deletePageFromRepository repos userID name
294 do let path = mkPagePath name
295 fs <- getRepositoryFS repos
296 rev <- getYoungestRev fs
297 status <- withRevision fs rev
298 $ do exists <- isFile path
300 do prop <- getNodeProp path "rakka:isLocked"
301 return $ case prop of
303 -> if isNothing userID then
312 when (status == NoContent)
313 $ do doReposTxn repos
316 (Just "Automatic commit by Rakka for page deleting")
317 $ do deleteEntry path
318 deleteEmptyParentDirectories path
323 deleteEmptyParentDirectories :: FilePath -> Txn ()
324 deleteEmptyParentDirectories path
325 = do let parentPath = takeDirectory path
326 contents <- getDirEntries parentPath
328 $ do deleteEntry parentPath
329 deleteEmptyParentDirectories parentPath
332 filterSvnError :: IO a -> IO a
333 filterSvnError f = catchDyn f rethrow
335 rethrow :: SvnError -> IO a
337 = let code = svnErrCode err
340 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg