1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , findChangedPagesAtRevision
5 , putPageIntoRepository
11 import qualified Data.Map as M
14 import qualified Data.Set as S hiding (Set)
16 import Network.HTTP.Lucu hiding (redirect)
18 import Rakka.SystemConfig
20 import Rakka.W3CDateTime
21 import Subversion.Types
22 import Subversion.FileSystem
23 import Subversion.FileSystem.DirEntry
24 import Subversion.FileSystem.Revision
25 import Subversion.FileSystem.Root
26 import Subversion.FileSystem.Transaction
27 import Subversion.Repository
28 import System.FilePath.Posix
31 mkPagePath :: PageName -> FilePath
33 = "pages" </> encodePageName name <.> "page"
36 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
37 findAllPagesInRevision repos rev
38 = do fs <- getRepositoryFS repos
40 $ do exists <- isDirectory root
49 traverse :: FilePath -> Rev (Set PageName)
51 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
53 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
55 = let path = dir </> entName entry
57 do kind <- checkPath path
59 NoNode -> return S.empty
60 FileNode -> return $ S.singleton (decodePath path)
61 DirNode -> traverse path
63 decodePath :: FilePath -> PageName
64 decodePath = decodePageName . makeRelative root . dropExtension
67 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
68 findChangedPagesAtRevision repos rev
69 = do fs <- getRepositoryFS repos
71 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
73 accumulatePages :: Set PageName -> FilePath -> Set PageName
74 accumulatePages s path
75 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
76 = let encoded = makeRelative "/pages" $ dropExtension path
77 name = decodePageName encoded
84 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
85 loadPageInRepository repos name rev
86 = do fs <- getRepositoryFS repos
88 Nothing -> getYoungestRev fs
91 $ do exists <- isFile path
94 -> return . Just =<< loadPage'
99 path = mkPagePath name
101 loadPage' :: Rev Page
102 loadPage' = do redirect <- getNodeProp path "rakka:redirect"
109 loadPageEntity :: Rev Page
111 = do props <- getNodePropList path
112 hist <- getNodeHistory True path
113 content <- getFileContentsLBS path
115 let pageRev = fst $ head hist
117 $ fromMaybe "text/x-rakka"
118 $ fmap chomp (lookup "svn:mime-type" props)
120 lastMod <- getRevisionProp "svn:date"
121 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
125 , entityType = mimeType
126 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
127 , entityFileName = fmap chomp (lookup "rakka:fileName" props)
128 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
129 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
130 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
131 , entityIsBoring = any ((== "rakka:isBoring") . fst) props
132 , entityIsBinary = case mimeType of
134 -> any ((== "rakka:isBinary") . fst) props
137 , entityRevision = pageRev
138 , entityLastMod = zonedTimeToUTC lastMod
139 , entitySummary = lookup "rakka:summary" props
140 , entityOtherLang = fromMaybe M.empty
142 (M.fromList . fromJust . deserializeStringPairs)
143 (lookup "rakka:otherLang" props)
144 , entityContent = content
145 , entityUpdateInfo = undefined
148 loadPageRedirect :: Rev Page
149 loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented"
152 putPageIntoRepository :: Repository -> Page -> IO StatusCode
153 putPageIntoRepository repos page
154 = do let Just ui = pageUpdateInfo page
160 (Just "Automatic commit by Rakka for page updating")
161 $ do case uiOldName ui of
163 Just oldName -> renamePage oldName name
164 createPageIfNeeded name
172 renamePage :: PageName -> PageName -> Txn ()
173 renamePage oldName newName
174 = fail "FIXME: renamePage: not implemented yet"
176 createPageIfNeeded :: PageName -> Txn ()
177 createPageIfNeeded name
178 = do let path = mkPagePath name
179 kind <- checkPath path
181 NoNode -> do createParentDirectories path
183 FileNode -> return ()
184 DirNode -> fail ("createPageIfNeeded: already exists a directory: " ++ path)
186 createParentDirectories :: FilePath -> Txn ()
187 createParentDirectories path
188 = do let parentPath = takeDirectory path
189 kind <- checkPath parentPath
191 NoNode -> createParentDirectories parentPath
192 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
195 updatePage :: PageName -> Txn ()
197 | isRedirect page = updatePageRedirect name
198 | isEntity page = updatePageEntity name
199 | otherwise = fail "neither redirection nor page"
201 updatePageRedirect :: PageName -> Txn ()
202 updatePageRedirect name
203 = fail "FIXME: updatePageRedirect: not implemented yet"
205 updatePageEntity :: PageName -> Txn ()
206 updatePageEntity name
207 = do let path = mkPagePath name
208 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
209 setNodeProp path "rakka:lang" (entityLanguage page)
210 setNodeProp path "rakka:fileName" (entityFileName page)
211 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
212 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
213 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
214 setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page)
215 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
216 setNodeProp path "rakka:summary" (entitySummary page)
217 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
219 if M.null otherLang then
222 Just (serializeStringPairs $ M.toList otherLang))
223 applyTextLBS path Nothing (entityContent page)
225 encodeFlag :: Bool -> Maybe String
226 encodeFlag True = Just "*\n"
227 encodeFlag False = Nothing