1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , findChangedPagesAtRevision
5 , putPageIntoRepository
9 import Codec.Binary.UTF8.String
10 import Control.Exception
13 import qualified Data.Map as M
16 import qualified Data.Set as S hiding (Set)
18 import Network.HTTP.Lucu hiding (redirect)
20 import Rakka.SystemConfig
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
34 mkPagePath :: PageName -> FilePath
36 = "/pages" </> encodePageName name <.> "page"
39 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
40 findAllPagesInRevision repos rev
41 = do fs <- getRepositoryFS repos
43 $ do exists <- isDirectory root
52 traverse :: FilePath -> Rev (Set PageName)
54 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
56 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
58 = let path = dir </> entName entry
60 do kind <- checkPath path
62 NoNode -> return S.empty
63 FileNode -> return $ S.singleton (decodePath path)
64 DirNode -> traverse path
66 decodePath :: FilePath -> PageName
67 decodePath = decodePageName . makeRelative root . dropExtension
70 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
71 findChangedPagesAtRevision repos rev
72 = do fs <- getRepositoryFS repos
74 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
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
87 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
88 loadPageInRepository repos name rev
89 = do fs <- getRepositoryFS repos
91 Nothing -> getYoungestRev fs
94 $ do exists <- isFile path
97 -> return . Just =<< loadPage'
102 path = mkPagePath name
104 loadPage' :: Rev Page
105 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
107 Just (MIMEType "application" "x-rakka-redirection" _)
112 loadPageEntity :: Rev Page
114 = do props <- getNodePropList path
115 hist <- getNodeHistory True path
116 content <- getFileContentsLBS path
118 let pageRev = fst $ head hist
120 $ fromMaybe "text/x-rakka"
121 $ fmap chomp (lookup "svn:mime-type" props)
123 lastMod <- getRevisionProp "svn:date"
124 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
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
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 -> Page -> IO StatusCode
171 putPageIntoRepository repos page
173 do let name = pageName page
174 ret <- case pageUpdateInfo page of
180 (Just "Automatic commit by Rakka for page update")
181 $ do case uiOldName ui of
183 Just oldName -> renamePage oldName name
186 -> do fs <- getRepositoryFS repos
187 rev <- getYoungestRev fs
191 (Just "Automatic commit by Rakka for page creation")
195 Left _ -> return Conflict
196 Right _ -> return Created
198 renamePage :: PageName -> PageName -> Txn ()
199 renamePage oldName newName
200 = fail "FIXME: renamePage: not implemented yet"
202 createPage :: PageName -> Txn ()
204 = do let path = mkPagePath name
205 createParentDirectories path
208 createParentDirectories :: FilePath -> Txn ()
209 createParentDirectories path
210 = do let parentPath = takeDirectory path
211 kind <- checkPath parentPath
213 NoNode -> do createParentDirectories parentPath
214 makeDirectory parentPath
215 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
218 updatePage :: PageName -> Txn ()
220 | isRedirect page = updatePageRedirect name
221 | isEntity page = updatePageEntity name
222 | otherwise = fail "neither redirection nor page"
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")
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
251 if M.null otherLang then
254 Just (serializeStringPairs $ M.toList otherLang))
255 applyTextLBS path Nothing (entityContent page)
257 encodeFlag :: Bool -> Maybe String
258 encodeFlag True = Just "*"
259 encodeFlag False = Nothing
262 filterSvnError :: IO a -> IO a
263 filterSvnError f = catchDyn f rethrow
265 rethrow :: SvnError -> IO a
267 = let code = svnErrCode err
270 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg