adapt functions to configurable extension

Framework.hs: - change isPageFile to get extension from config - add isNotDiscussPageFile - pathForPage must be passed extension as String changes to functions in other modules to deal with fact that isPageFile now returns GititServerPart Bool instead of just Bool.
jgm · Aug 16, 2014 · d98c60c · wouteroostervld · Aug 24, 2015 · d98c60c
1 parent 7be7dfc
commit d98c60c
Show file tree

Hide file tree

Showing 7 changed files with 93 additions and 63 deletions.
diff --git a/Network/Gitit/Cache.hs b/Network/Gitit/Cache.hs
@@ -50,11 +50,11 @@ expireCachedFile file = do
   exists <- liftIO $ doesFileExist target
   when exists $ liftIO $ do
     liftIO $ removeFile target
-    expireCachedPDF target
+    expireCachedPDF target (defaultExtension cfg)
 
-expireCachedPDF :: String -> IO ()
-expireCachedPDF file =
-  when (takeExtension file == ".page") $ do
+expireCachedPDF :: String -> String -> IO ()
+expireCachedPDF file ext = 
+  when (takeExtension file == "." ++ ext) $ do
     let pdfname = file ++ ".export.pdf"
     exists <- doesFileExist pdfname
     when exists $ removeFile pdfname
@@ -84,4 +84,4 @@ cacheContents file contents = do
   liftIO $ do
     createDirectoryIfMissing True targetDir
     B.writeFile target contents
-    expireCachedPDF target
+    expireCachedPDF target (defaultExtension cfg)
diff --git a/Network/Gitit/Config.hs b/Network/Gitit/Config.hs
@@ -83,7 +83,7 @@ extractConfig cp = do
       cfRepositoryType <- get cp "DEFAULT" "repository-type"
       cfRepositoryPath <- get cp "DEFAULT" "repository-path"
       cfDefaultPageType <- get cp "DEFAULT" "default-page-type"
-      cfDefaultExtension <- get cp "DEFAULT" "default-page-type"
+      cfDefaultExtension <- get cp "DEFAULT" "default-extension"
       cfMathMethod <- get cp "DEFAULT" "math"
       cfMathjaxScript <- get cp "DEFAULT" "mathjax-script"
       cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks"

diff --git a/Network/Gitit/ContentTransformer.hs b/Network/Gitit/ContentTransformer.hs
@@ -111,14 +111,33 @@ import Text.URI (parseURI, URI(..), uriQueryItems)
 -- ContentTransformer runners
 --
 
-runTransformer :: ToMessage a
-               => (String -> String)
-               -> ContentTransformer a
+runPageTransformer :: ToMessage a
+               => ContentTransformer a
+               -> GititServerPart a
+runPageTransformer xform = withData $ \params -> do
+  page <- getPage
+  cfg <- getConfig
+  evalStateT xform  Context{ ctxFile = pathForPage page (defaultExtension cfg)
+                           , ctxLayout = defaultPageLayout{
+                                             pgPageName = page
+                                           , pgTitle = page
+                                           , pgPrintable = pPrintable params
+                                           , pgMessages = pMessages params
+                                           , pgRevision = pRevision params
+                                           , pgLinkToFeed = useFeed cfg }
+                           , ctxCacheable = True
+                           , ctxTOC = tableOfContents cfg
+                           , ctxBirdTracks = showLHSBirdTracks cfg
+                           , ctxCategories = []
+                           , ctxMeta = [] }
+
+runFileTransformer :: ToMessage a
+               => ContentTransformer a
                -> GititServerPart a
-runTransformer pathFor xform = withData $ \params -> do
+runFileTransformer xform = withData $ \params -> do
   page <- getPage
   cfg <- getConfig
-  evalStateT xform  Context{ ctxFile = pathFor page
+  evalStateT xform  Context{ ctxFile = id page
                            , ctxLayout = defaultPageLayout{
                                              pgPageName = page
                                            , pgTitle = page
@@ -134,17 +153,17 @@ runTransformer pathFor xform = withData $ \params -> do
 
 -- | Converts a @ContentTransformer@ into a @GititServerPart@;
 -- specialized to wiki pages.
-runPageTransformer :: ToMessage a
-                   => ContentTransformer a
-                   -> GititServerPart a
-runPageTransformer = runTransformer pathForPage
+-- runPageTransformer :: ToMessage a
+--                    => ContentTransformer a
+--                    -> GititServerPart a
+-- runPageTransformer = runTransformer pathForPage
 
 -- | Converts a @ContentTransformer@ into a @GititServerPart@;
 -- specialized to non-pages.
-runFileTransformer :: ToMessage a
-                   => ContentTransformer a
-                   -> GititServerPart a
-runFileTransformer = runTransformer id
+-- runFileTransformer :: ToMessage a
+--                    => ContentTransformer a
+--                    -> GititServerPart a
+-- runFileTransformer = runTransformer id
 
 --
 -- Gitit responders

diff --git a/Network/Gitit/Export.hs b/Network/Gitit/Export.hs
@@ -214,7 +214,7 @@ respondPDF :: Bool -> String -> Pandoc -> Handler
 respondPDF useBeamer page old_pndc = fixURLs page old_pndc >>= \pndc -> do
   cfg <- getConfig
   unless (pdfExport cfg) $ error "PDF export disabled"
-  let cacheName = pathForPage page ++ ".export.pdf"
+  let cacheName = pathForPage page (defaultExtension cfg) ++ ".export.pdf"
   cached <- if useCache cfg
                then lookupCache cacheName
                else return Nothing

diff --git a/Network/Gitit/Framework.hs b/Network/Gitit/Framework.hs
@@ -43,6 +43,7 @@ module Network.Gitit.Framework (
                                , isPageFile
                                , isDiscussPage
                                , isDiscussPageFile
+                               , isNotDiscussPageFile
                                , isSourceCode
                                -- * Combinators that change the request locally
                                , withMessages
@@ -255,16 +256,22 @@ isPage s = all (`notElem` "*?") s && not (".." `isInfixOf` s) && not ("/_" `isIn
 -- for now, we disallow @*@ and @?@ in page names, because git filestore
 -- does not deal with them properly, and darcs filestore disallows them.
 
-isPageFile :: FilePath -> Bool
-isPageFile f = takeExtension f == ".page"
+isPageFile :: FilePath -> GititServerPart Bool
+isPageFile f = do
+  cfg <- getConfig
+  return $ takeExtension f == "." ++ (defaultExtension cfg)
 
 isDiscussPage :: String -> Bool
 isDiscussPage ('@':xs) = isPage xs
 isDiscussPage _ = False
 
-isDiscussPageFile :: FilePath -> Bool
+isDiscussPageFile :: FilePath -> GititServerPart Bool
 isDiscussPageFile ('@':xs) = isPageFile xs
-isDiscussPageFile _ = False
+isDiscussPageFile _ = return False
+
+isNotDiscussPageFile :: FilePath -> GititServerPart Bool
+isNotDiscussPageFile ('@':_) = return False
+isNotDiscussPageFile _ = return True
 
 isSourceCode :: String -> Bool
 isSourceCode path' =
@@ -279,8 +286,8 @@ urlForPage :: String -> String
 urlForPage page = '/' : encString False isUnescapedInURI page
 
 -- | Returns the filestore path of the file containing the page's source.
-pathForPage :: String -> FilePath
-pathForPage page = page <.> "page"
+pathForPage :: String -> String -> FilePath
+pathForPage page ext = page <.> ext
 
 -- | Retrieves a mime type based on file extension.
 getMimeTypeForExtension :: String -> GititServerPart String

diff --git a/Network/Gitit/Handlers.hs b/Network/Gitit/Handlers.hs
@@ -111,10 +111,9 @@ debugHandler = withData $ \(params :: Params) -> do
 randomPage :: Handler
 randomPage = do
   fs <- getFileStore
-  files <- liftIO $ index fs
   base' <- getWikiBase
-  let pages = map dropExtension $
-              filter (\f -> isPageFile f && not (isDiscussPageFile f)) files
+  prunedFiles <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
+  let pages = map dropExtension prunedFiles
   if null pages
      then error "No pages found!"
      else do
@@ -194,6 +193,7 @@ uploadFile = withData $ \(params :: Params) -> do
                  $ pWikiname params `orIfNull` takeFileName origPath
   let logMsg = pLogMsg params
   cfg <- getConfig
+  wPF <- isPageFile wikiname
   mbUser <- getLoggedInUser
   (user, email) <- case mbUser of
                         Nothing -> return ("Anonymous", "")
@@ -218,7 +218,7 @@ uploadFile = withData $ \(params :: Params) -> do
                  , (not overwrite && exists, "A file named '" ++ wikiname ++
                     "' already exists in the repository: choose a new name " ++
                     "or check the box to overwrite the existing file.")
-                 , (isPageFile wikiname,
+                 , (wPF,
                     "This file extension is reserved for wiki pages.")
                  ]
   if null errors
@@ -246,8 +246,8 @@ goToPage :: Handler
 goToPage = withData $ \(params :: Params) -> do
   let gotopage = pGotoPage params
   fs <- getFileStore
-  allPageNames <- liftM (map dropExtension . filter isPageFile) $
-                   liftIO $ index fs
+  pruned_files <- liftIO (index fs) >>= filterM isPageFile
+  let allPageNames = map dropExtension pruned_files
   let findPage f = find f allPageNames
   let exactMatch f = gotopage == f
   let insensitiveMatch f = (map toLower gotopage) == (map toLower f)
@@ -281,14 +281,14 @@ searchResults = withData $ \(params :: Params) -> do
                                        -- doesn't handle this properly:
                                        (\(_ :: FileStoreError)  -> return [])
   let contentMatches = map matchResourceName matchLines
-  allPages <- liftM (filter isPageFile) $ liftIO $ index fs
+  allPages <- liftIO (index fs) >>= filterM isPageFile
   let slashToSpace = map (\c -> if c == '/' then ' ' else c)
   let inPageName pageName' x = x `elem` (words $ slashToSpace $ dropExtension pageName')
   let matchesPatterns pageName' = not (null patterns) &&
        all (inPageName (map toLower pageName')) (map (map toLower) patterns)
   let pageNameMatches = filter matchesPatterns allPages
-  let allMatchedFiles = nub $ filter isPageFile contentMatches ++
-                              pageNameMatches
+  prunedFiles <- filterM isPageFile (contentMatches ++ pageNameMatches)
+  let allMatchedFiles = nub $ prunedFiles
   let matchesInFile f =  mapMaybe (\x -> if matchResourceName x == f
                                             then Just (matchLine x)
                                             else Nothing) matchLines
@@ -324,7 +324,8 @@ searchResults = withData $ \(params :: Params) -> do
 showPageHistory :: Handler
 showPageHistory = withData $ \(params :: Params) -> do
   page <- getPage
-  showHistory (pathForPage page) page params
+  cfg <- getConfig
+  showHistory (pathForPage page $ defaultExtension cfg) page params
 
 showFileHistory :: Handler
 showFileHistory = withData $ \(params :: Params) -> do
@@ -403,9 +404,8 @@ showActivity = withData $ \(params :: Params) -> do
   let fileFromChange (Added f)    = f
       fileFromChange (Modified f) = f
       fileFromChange (Deleted f)  = f
-
   base' <- getWikiBase
-  let fileAnchor revis file = if isPageFile file
+  let fileAnchor revis file = if takeExtension file == "." ++ (defaultExtension cfg)
         then anchor ! [href $ base' ++ "/_diff" ++ urlForPage (dropExtension file) ++ "?to=" ++ revis] << dropExtension file
         else anchor ! [href $ base' ++ urlForPage file ++ "?revision=" ++ revis] << file
   let filesFor changes revis = intersperse (stringToHtml " ") $
@@ -435,7 +435,8 @@ showActivity = withData $ \(params :: Params) -> do
 showPageDiff :: Handler
 showPageDiff = withData $ \(params :: Params) -> do
   page <- getPage
-  showDiff (pathForPage page) page params
+  cfg <- getConfig
+  showDiff (pathForPage page $ defaultExtension cfg) page params
 
 showFileDiff :: Handler
 showFileDiff = withData $ \(params :: Params) -> do
@@ -499,13 +500,14 @@ editPage' params = do
   let rev = pRevision params  -- if this is set, we're doing a revert
   fs <- getFileStore
   page <- getPage
+  cfg <- getConfig
   let getRevisionAndText = E.catch
-        (do c <- liftIO $ retrieve fs (pathForPage page) rev
+        (do c <- liftIO $ retrieve fs (pathForPage page $ defaultExtension cfg) rev
             -- even if pRevision is set, we return revId of latest
             -- saved version (because we're doing a revert and
             -- we don't want gitit to merge the changes with the
             -- latest version)
-            r <- liftIO $ latest fs (pathForPage page) >>= revision fs
+            r <- liftIO $ latest fs (pathForPage page $ defaultExtension cfg) >>= revision fs
             return (Just $ revId r, c))
         (\e -> if e == NotFound
                   then return (Nothing, "")
@@ -528,7 +530,6 @@ editPage' params = do
                           strAttr "style" "color: gray"]
                     else []
   base' <- getWikiBase
-  cfg <- getConfig
   let editForm = gui (base' ++ urlForPage page) ! [identifier "editform"] <<
                    [ sha1Box
                    , textarea ! (readonly ++ [cols "80", name "editedText",
@@ -570,11 +571,12 @@ confirmDelete :: Handler
 confirmDelete = do
   page <- getPage
   fs <- getFileStore
+  cfg <- getConfig
   -- determine whether there is a corresponding page, and if not whether there
   -- is a corresponding file
-  pageTest <- liftIO $ E.try $ latest fs (pathForPage page)
+  pageTest <- liftIO $ E.try $ latest fs (pathForPage page $ defaultExtension cfg)
   fileToDelete <- case pageTest of
-                       Right _        -> return $ pathForPage page  -- a page
+                       Right _        -> return $ pathForPage page $ defaultExtension cfg -- a page
                        Left  NotFound -> do
                          fileTest <- liftIO $ E.try $ latest fs page
                          case fileTest of
@@ -599,6 +601,7 @@ confirmDelete = do
 deletePage :: Handler
 deletePage = withData $ \(params :: Params) -> do
   page <- getPage
+  cfg <- getConfig
   let file = pFileToDelete params
   mbUser <- getLoggedInUser
   (user, email) <- case mbUser of
@@ -607,7 +610,7 @@ deletePage = withData $ \(params :: Params) -> do
   let author = Author user email
   let descrip = "Deleted using web interface."
   base' <- getWikiBase
-  if pConfirm params && (file == page || file == page <.> "page")
+  if pConfirm params && (file == page || file == page <.> (defaultExtension cfg))
      then do
        fs <- getFileStore
        liftIO $ Data.FileStore.delete fs file author descrip
@@ -636,12 +639,12 @@ updatePage = withData $ \(params :: Params) -> do
           error "Page exceeds maximum size."
        -- check SHA1 in case page has been modified, merge
        modifyRes <- if null oldSHA1
-                       then liftIO $ create fs (pathForPage page)
+                       then liftIO $ create fs (pathForPage page $ defaultExtension cfg)
                                        (Author user email) logMsg editedText >>
                                      return (Right ())
                        else do
-                         expireCachedFile (pathForPage page) `mplus` return ()
-                         liftIO $ E.catch (modify fs (pathForPage page)
+                         expireCachedFile (pathForPage page $ defaultExtension cfg) `mplus` return ()
+                         liftIO $ E.catch (modify fs (pathForPage page $ defaultExtension cfg)
                                             oldSHA1 (Author user email) logMsg
                                             editedText)
                                      (\e -> if e == Unchanged
@@ -665,23 +668,25 @@ indexPage :: Handler
 indexPage = do
   path' <- getPath
   base' <- getWikiBase
+  cfg <- getConfig
+  let ext = defaultExtension cfg
   let prefix' = if null path' then "" else path' ++ "/"
   fs <- getFileStore
   listing <- liftIO $ directory fs prefix'
-  let isDiscussionPage (FSFile f) = isDiscussPageFile f
-      isDiscussionPage (FSDirectory _) = False
-  let prunedListing = filter (not . isDiscussionPage) listing
-  let htmlIndex = fileListToHtml base' prefix' prunedListing
+  let isNotDiscussionPage (FSFile f) = isNotDiscussPageFile f
+      isNotDiscussionPage (FSDirectory _) = return True
+  prunedListing <- filterM isNotDiscussionPage listing
+  let htmlIndex = fileListToHtml base' prefix' ext prunedListing
   formattedPage defaultPageLayout{
                   pgPageName = prefix',
                   pgShowPageTools = False,
                   pgTabs = [],
                   pgScripts = [],
                   pgTitle = "Contents"} htmlIndex
 
-fileListToHtml :: String -> String -> [Resource] -> Html
-fileListToHtml base' prefix files =
-  let fileLink (FSFile f) | isPageFile f =
+fileListToHtml :: String -> String -> String -> [Resource] -> Html
+fileListToHtml base' prefix ext files =
+  let fileLink (FSFile f) | takeExtension f == "." ++ ext =
         li ! [theclass "page"  ] <<
           anchor ! [href $ base' ++ urlForPage (prefix ++ dropExtension f)] <<
             dropExtension f
@@ -713,8 +718,7 @@ categoryPage = do
   let repoPath = repositoryPath cfg
   let categoryDescription = "Category: " ++ (intercalate " + " pcategories)
   fs <- getFileStore
-  files <- liftIO $ index fs
-  let pages = filter (\f -> isPageFile f && not (isDiscussPageFile f)) files
+  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
   matches <- liftM catMaybes $
              forM pages $ \f -> do
                categories <- liftIO $ readCategories $ repoPath </> f
@@ -751,8 +755,7 @@ categoryListPage = do
   cfg <- getConfig
   let repoPath = repositoryPath cfg
   fs <- getFileStore
-  files <- liftIO $ index fs
-  let pages = filter (\f -> isPageFile f && not (isDiscussPageFile f)) files
+  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
   categories <- liftIO $ liftM (nub . sort . concat) $ forM pages $ \f ->
                   readCategories (repoPath </> f)
   base' <- getWikiBase
@@ -769,8 +772,9 @@ categoryListPage = do
 expireCache :: Handler
 expireCache = do
   page <- getPage
+  cfg <- getConfig
   -- try it as a page first, then as an uploaded file
-  expireCachedFile (pathForPage page)
+  expireCachedFile (pathForPage page $ defaultExtension cfg)
   expireCachedFile page
   ok $ toResponse ()
 

diff --git a/Network/Gitit/Initialize.hs b/Network/Gitit/Initialize.hs
@@ -154,11 +154,11 @@ createDefaultPages conf = do
           "\n...\n\n"
     -- add front page, help page, and user's guide
     let auth = Author "Gitit" ""
-    createIfMissing fs (frontPage conf <.> "page") auth "Default front page"
+    createIfMissing fs (frontPage conf <.> defaultExtension conf) auth "Default front page"
       $ header ++ welcomecontents
-    createIfMissing fs "Help.page" auth "Default help page"
+    createIfMissing fs ("Help" <.> defaultExtension conf) auth "Default help page"
       $ header ++ helpcontents
-    createIfMissing fs "Gitit User’s Guide.page" auth "User’s guide (README)"
+    createIfMissing fs ("Gitit User's Guide" <.> defaultExtension conf) auth "User's guide (README)"
       $ header ++ usersguidecontents
 
 createIfMissing :: FileStore -> FilePath -> Author -> Description -> String -> IO ()