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 , entityIsBoring = any ((== "rakka:isBoring") . fst) props
135 , entityIsBinary = case mimeType of
137 -> any ((== "rakka:isBinary") . fst) props
140 , entityRevision = pageRev
141 , entityLastMod = zonedTimeToUTC lastMod
142 , entitySummary = lookup "rakka:summary" props
143 , entityOtherLang = fromMaybe M.empty
145 (M.fromList . fromJust . deserializeStringPairs)
146 (lookup "rakka:otherLang" props)
147 , entityContent = content
148 , entityUpdateInfo = undefined
151 loadPageRedirect :: Rev Page
153 = do hist <- getNodeHistory True path
154 content <- getFileContents path
156 let pageRev = fst $ head hist
157 dest = chomp $ decodeString content
159 lastMod <- getRevisionProp "svn:date"
160 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
165 , redirRevision = pageRev
166 , redirLastMod = zonedTimeToUTC lastMod
167 , redirUpdateInfo = undefined
171 putPageIntoRepository :: Repository -> Page -> IO StatusCode
172 putPageIntoRepository repos page
174 do let name = pageName page
175 ret <- case pageUpdateInfo page of
181 (Just "Automatic commit by Rakka for page update")
182 $ do case uiOldName ui of
184 Just oldName -> renamePage (uiOldRevision ui) oldName name
187 -> do fs <- getRepositoryFS repos
188 rev <- getYoungestRev fs
192 (Just "Automatic commit by Rakka for page creation")
196 Left _ -> return Conflict
197 Right _ -> return Created
199 renamePage :: RevNum -> PageName -> PageName -> Txn ()
200 renamePage oldRev oldName newName
201 = do let oldPath = mkPagePath oldName
202 newPath = mkPagePath newName
203 createParentDirectories newPath
204 copyEntry oldRev oldPath newPath
206 deleteEmptyParentDirectories oldPath
208 createPage :: PageName -> Txn ()
210 = do let path = mkPagePath name
211 createParentDirectories path
214 updatePage :: PageName -> Txn ()
216 | isRedirect page = updatePageRedirect name
217 | isEntity page = updatePageEntity name
218 | otherwise = fail "neither redirection nor page"
220 updatePageRedirect :: PageName -> Txn ()
221 updatePageRedirect name
222 = do let path = mkPagePath name
223 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
224 setNodeProp path "rakka:lang" Nothing
225 setNodeProp path "rakka:isTheme" Nothing
226 setNodeProp path "rakka:isFeed" Nothing
227 setNodeProp path "rakka:isLocked" Nothing
228 setNodeProp path "rakka:isBoring" Nothing
229 setNodeProp path "rakka:isBinary" Nothing
230 setNodeProp path "rakka:summary" Nothing
231 setNodeProp path "rakka:otherLang" Nothing
232 applyText path Nothing (encodeString (redirDest page) ++ "\n")
234 updatePageEntity :: PageName -> Txn ()
235 updatePageEntity name
236 = do let path = mkPagePath name
237 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
238 setNodeProp path "rakka:lang" (entityLanguage page)
239 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
240 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
241 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
242 setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page)
243 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
244 setNodeProp path "rakka:summary" (entitySummary page)
245 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
247 if M.null otherLang then
250 Just (serializeStringPairs $ M.toList otherLang))
251 applyTextLBS path Nothing (entityContent page)
253 encodeFlag :: Bool -> Maybe String
254 encodeFlag True = Just "*"
255 encodeFlag False = Nothing
258 createParentDirectories :: FilePath -> Txn ()
259 createParentDirectories path
260 = do let parentPath = takeDirectory path
261 kind <- checkPath parentPath
263 NoNode -> do createParentDirectories parentPath
264 makeDirectory parentPath
265 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
269 deletePageFromRepository :: Repository -> PageName -> IO StatusCode
270 deletePageFromRepository repos name
272 do let path = mkPagePath name
273 fs <- getRepositoryFS repos
274 rev <- getYoungestRev fs
275 exists <- withRevision fs rev $ isFile path
280 (Just "Automatic commit by Rakka for page deleting")
281 $ do deleteEntry path
282 deleteEmptyParentDirectories path
288 deleteEmptyParentDirectories :: FilePath -> Txn ()
289 deleteEmptyParentDirectories path
290 = do let parentPath = takeDirectory path
291 contents <- getDirEntries parentPath
293 $ do deleteEntry parentPath
294 deleteEmptyParentDirectories parentPath
297 filterSvnError :: IO a -> IO a
298 filterSvnError f = catchDyn f rethrow
300 rethrow :: SvnError -> IO a
302 = let code = svnErrCode err
305 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg