1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , getDirContentsInRevision
4 , findChangedPagesAtRevision
6 , putPageIntoRepository
7 , deletePageFromRepository
11 import Codec.Binary.UTF8.String
12 import Control.Exception
15 import qualified Data.Map as M
18 import qualified Data.Set as S hiding (Set)
20 import Network.HTTP.Lucu hiding (redirect)
22 import Rakka.SystemConfig
24 import Rakka.W3CDateTime
25 import Subversion.Error
26 import Subversion.FileSystem
27 import Subversion.FileSystem.DirEntry
28 import Subversion.FileSystem.Revision
29 import Subversion.FileSystem.Root
30 import Subversion.FileSystem.Transaction
31 import Subversion.Repository
32 import Subversion.Types
33 import System.FilePath.Posix
36 mkPagePath :: PageName -> FilePath
38 = "/pages" </> encodePageName name <.> "page"
41 mkDirPath :: PageName -> FilePath
43 = "/pages" </> encodePageName dir
46 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
47 findAllPagesInRevision repos rev
48 = do fs <- getRepositoryFS repos
50 $ do exists <- isDirectory root
59 traverse :: FilePath -> Rev (Set PageName)
61 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
63 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
65 = let path = dir </> entName entry
67 do kind <- checkPath path
69 NoNode -> return S.empty
70 FileNode -> return $ S.singleton (decodePath path)
71 DirNode -> traverse path
73 decodePath :: FilePath -> PageName
74 decodePath = decodePageName . makeRelative root . dropExtension
77 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
78 getDirContentsInRevision repos dir rev
79 = do fs <- getRepositoryFS repos
81 Nothing -> getYoungestRev fs
84 $ do exists <- isDirectory path
86 return . S.fromList =<< getDir'
93 getDir' :: Rev [PageName]
94 getDir' = getDirEntries path >>= return . map entToName
96 entToName :: DirEntry -> PageName
97 entToName = (dir </>) . decodePageName . dropExtension . entName
100 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
101 findChangedPagesAtRevision repos rev
102 = do fs <- getRepositoryFS repos
104 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
106 accumulatePages :: Set PageName -> FilePath -> Set PageName
107 accumulatePages s path
108 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
109 = let encoded = makeRelative "/pages" $ dropExtension path
110 name = decodePageName encoded
117 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
118 loadPageInRepository repos name rev
119 = do fs <- getRepositoryFS repos
121 Nothing -> getYoungestRev fs
124 $ do exists <- isFile path
126 return . Just =<< loadPage'
131 path = mkPagePath name
133 loadPage' :: Rev Page
134 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
136 Just (MIMEType "application" "x-rakka-redirection" _)
141 loadPageEntity :: Rev Page
143 = do props <- getNodePropList path
144 hist <- getNodeHistory True path
145 content <- getFileContentsLBS path
147 let pageRev = fst $ head hist
149 $ fromMaybe "text/x-rakka"
150 $ fmap chomp (lookup "svn:mime-type" props)
152 lastMod <- getRevisionProp "svn:date"
153 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
157 , entityType = mimeType
158 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
159 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
160 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
161 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
162 , entityIsBinary = case mimeType of
164 -> any ((== "rakka:isBinary") . fst) props
167 , entityRevision = pageRev
168 , entityLastMod = zonedTimeToUTC lastMod
169 , entitySummary = lookup "rakka:summary" props
170 , entityOtherLang = fromMaybe M.empty
172 (M.fromList . fromJust . deserializeStringPairs)
173 (lookup "rakka:otherLang" props)
174 , entityContent = content
175 , entityUpdateInfo = undefined
178 loadPageRedirect :: Rev Page
180 = do hist <- getNodeHistory True path
181 content <- getFileContents path
183 let pageRev = fst $ head hist
184 dest = chomp $ decodeString content
186 lastMod <- getRevisionProp "svn:date"
187 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
189 isLocked <- getRevisionProp "rakka:isLocked"
195 , redirIsLocked = isLocked
196 , redirRevision = pageRev
197 , redirLastMod = zonedTimeToUTC lastMod
198 , redirUpdateInfo = undefined
202 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
203 putPageIntoRepository repos userID page
205 do let name = pageName page
206 author = fromMaybe "[Rakka]" userID
207 case pageUpdateInfo page of
209 -> do let oldRev = uiOldRevision ui
210 denied <- case uiOldName ui of
211 Nothing -> checkDenial oldRev name
212 Just oldName -> checkDenial oldRev oldName
220 (Just "Automatic commit by Rakka for page update")
221 $ do case uiOldName ui of
223 Just oldName -> renamePage (uiOldRevision ui) oldName name
226 Left _ -> return Conflict
227 Right _ -> return Created
229 -> do fs <- getRepositoryFS repos
230 rev <- getYoungestRev fs
235 (Just "Automatic commit by Rakka for page creation")
239 Left _ -> return Conflict
240 Right _ -> return Created
242 checkDenial :: RevNum -> PageName -> IO Bool
244 = do fs <- getRepositoryFS repos
246 $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
248 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
249 Nothing -> return False
251 renamePage :: RevNum -> PageName -> PageName -> Txn ()
252 renamePage oldRev oldName newName
253 = do let oldPath = mkPagePath oldName
254 newPath = mkPagePath newName
255 createParentDirectories newPath
256 copyEntry oldRev oldPath newPath
258 deleteEmptyParentDirectories oldPath
260 createPage :: PageName -> Txn ()
262 = do let path = mkPagePath name
263 createParentDirectories path
266 updatePage :: PageName -> Txn ()
268 | isRedirect page = updatePageRedirect name
269 | isEntity page = updatePageEntity name
270 | otherwise = fail "neither redirection nor page"
272 updatePageRedirect :: PageName -> Txn ()
273 updatePageRedirect name
274 = do let path = mkPagePath name
275 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
276 setNodeProp path "rakka:lang" Nothing
277 setNodeProp path "rakka:isTheme" Nothing
278 setNodeProp path "rakka:isFeed" Nothing
279 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
280 setNodeProp path "rakka:isBinary" Nothing
281 setNodeProp path "rakka:summary" Nothing
282 setNodeProp path "rakka:otherLang" Nothing
283 applyText path Nothing (encodeString (redirDest page) ++ "\n")
285 updatePageEntity :: PageName -> Txn ()
286 updatePageEntity name
287 = do let path = mkPagePath name
288 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
289 setNodeProp path "rakka:lang" (entityLanguage page)
290 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
291 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
292 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
293 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
294 setNodeProp path "rakka:summary" (entitySummary page)
295 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
297 if M.null otherLang then
300 Just (serializeStringPairs $ M.toList otherLang))
301 applyTextLBS path Nothing (entityContent page)
303 encodeFlag :: Bool -> Maybe String
304 encodeFlag True = Just "*"
305 encodeFlag False = Nothing
308 createParentDirectories :: FilePath -> Txn ()
309 createParentDirectories path
310 = do let parentPath = takeDirectory path
311 kind <- checkPath parentPath
313 NoNode -> do createParentDirectories parentPath
314 makeDirectory parentPath
315 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
319 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
320 deletePageFromRepository repos userID name
322 do let path = mkPagePath name
323 fs <- getRepositoryFS repos
324 rev <- getYoungestRev fs
325 status <- withRevision fs rev
326 $ do exists <- isFile path
328 do prop <- getNodeProp path "rakka:isLocked"
329 return $ case prop of
331 -> if isNothing userID then
340 when (status == NoContent)
341 $ do doReposTxn repos
344 (Just "Automatic commit by Rakka for page deleting")
345 $ do deleteEntry path
346 deleteEmptyParentDirectories path
351 deleteEmptyParentDirectories :: FilePath -> Txn ()
352 deleteEmptyParentDirectories path
353 = do let parentPath = takeDirectory path
354 contents <- getDirEntries parentPath
356 $ do deleteEntry parentPath
357 deleteEmptyParentDirectories parentPath
360 filterSvnError :: IO a -> IO a
361 filterSvnError f = catchDyn f rethrow
363 rethrow :: SvnError -> IO a
365 = let code = svnErrCode err
368 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg