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
164 , redirRevision = pageRev
165 , redirLastMod = zonedTimeToUTC lastMod
166 , redirUpdateInfo = undefined
170 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
171 putPageIntoRepository repos userID page
173 do let name = pageName page
174 author = fromMaybe "[Rakka]" userID
175 case pageUpdateInfo page of
177 -> do let oldRev = uiOldRevision ui
178 denied <- case uiOldName ui of
179 Nothing -> checkDenial oldRev name
180 Just oldName -> checkDenial oldRev oldName
188 (Just "Automatic commit by Rakka for page update")
189 $ do case uiOldName ui of
191 Just oldName -> renamePage (uiOldRevision ui) oldName name
194 Left _ -> return Conflict
195 Right _ -> return Created
197 -> do fs <- getRepositoryFS repos
198 rev <- getYoungestRev fs
203 (Just "Automatic commit by Rakka for page creation")
207 Left _ -> return Conflict
208 Right _ -> return Created
210 checkDenial :: RevNum -> PageName -> IO Bool
212 = do fs <- getRepositoryFS repos
214 $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
216 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
217 Nothing -> return False
219 renamePage :: RevNum -> PageName -> PageName -> Txn ()
220 renamePage oldRev oldName newName
221 = do let oldPath = mkPagePath oldName
222 newPath = mkPagePath newName
223 createParentDirectories newPath
224 copyEntry oldRev oldPath newPath
226 deleteEmptyParentDirectories oldPath
228 createPage :: PageName -> Txn ()
230 = do let path = mkPagePath name
231 createParentDirectories path
234 updatePage :: PageName -> Txn ()
236 | isRedirect page = updatePageRedirect name
237 | isEntity page = updatePageEntity name
238 | otherwise = fail "neither redirection nor page"
240 updatePageRedirect :: PageName -> Txn ()
241 updatePageRedirect name
242 = do let path = mkPagePath name
243 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
244 setNodeProp path "rakka:lang" Nothing
245 setNodeProp path "rakka:isTheme" Nothing
246 setNodeProp path "rakka:isFeed" Nothing
247 setNodeProp path "rakka:isLocked" Nothing
248 setNodeProp path "rakka:isBinary" Nothing
249 setNodeProp path "rakka:summary" Nothing
250 setNodeProp path "rakka:otherLang" Nothing
251 applyText path Nothing (encodeString (redirDest page) ++ "\n")
253 updatePageEntity :: PageName -> Txn ()
254 updatePageEntity name
255 = do let path = mkPagePath name
256 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
257 setNodeProp path "rakka:lang" (entityLanguage page)
258 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
259 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
260 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
261 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
262 setNodeProp path "rakka:summary" (entitySummary page)
263 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
265 if M.null otherLang then
268 Just (serializeStringPairs $ M.toList otherLang))
269 applyTextLBS path Nothing (entityContent page)
271 encodeFlag :: Bool -> Maybe String
272 encodeFlag True = Just "*"
273 encodeFlag False = Nothing
276 createParentDirectories :: FilePath -> Txn ()
277 createParentDirectories path
278 = do let parentPath = takeDirectory path
279 kind <- checkPath parentPath
281 NoNode -> do createParentDirectories parentPath
282 makeDirectory parentPath
283 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
287 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
288 deletePageFromRepository repos userID name
290 do let path = mkPagePath name
291 fs <- getRepositoryFS repos
292 rev <- getYoungestRev fs
293 status <- withRevision fs rev
294 $ do exists <- isFile path
296 do prop <- getNodeProp path "rakka:isLocked"
297 return $ case prop of
299 -> if isNothing userID then
308 when (status == NoContent)
309 $ do doReposTxn repos
312 (Just "Automatic commit by Rakka for page deleting")
313 $ do deleteEntry path
314 deleteEmptyParentDirectories path
319 deleteEmptyParentDirectories :: FilePath -> Txn ()
320 deleteEmptyParentDirectories path
321 = do let parentPath = takeDirectory path
322 contents <- getDirEntries parentPath
324 $ do deleteEntry parentPath
325 deleteEmptyParentDirectories parentPath
328 filterSvnError :: IO a -> IO a
329 filterSvnError f = catchDyn f rethrow
331 rethrow :: SvnError -> IO a
333 = let code = svnErrCode err
336 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg