{-# LANGUAGE ScopedTypeVariables #-}
{-
Copyright (C) 2008-9 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- Handlers for wiki functions.
-}

module Network.Gitit.Handlers (
                        handleAny
                      , debugHandler
                      , randomPage
                      , discussPage
                      , createPage
                      , showActivity
                      , goToPage
                      , searchResults
                      , uploadForm
                      , uploadFile
                      , indexPage
                      , categoryPage
                      , categoryListPage
                      , preview
                      , showRawPage
                      , showFileAsText
                      , showPageHistory
                      , showFileHistory
                      , showPage
                      , showPageDiff
                      , showFileDiff
                      , updatePage
                      , editPage
                      , deletePage
                      , confirmDelete
                      , showHighlightedSource
                      , expireCache
                      , feedHandler
                      )
where
import Safe
import Network.Gitit.Server
import Network.Gitit.Framework
import Network.Gitit.Layout
import Network.Gitit.Types
import Network.Gitit.Feed (filestoreToXmlFeed, FeedConfig(..))
import Network.Gitit.Util (orIfNull)
import Network.Gitit.Cache (expireCachedFile, lookupCache, cacheContents)
import Network.Gitit.ContentTransformer (showRawPage, showFileAsText, showPage,
        showHighlightedSource, preview, applyPreCommitPlugins)
import Network.Gitit.Page (readCategories)
import qualified Control.Exception as E
import System.FilePath
import Network.Gitit.State
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import qualified Text.XHtml as X ( method )
import Data.List (intercalate, intersperse, delete, nub, sortBy, find, isPrefixOf, inits, sort, (\\))
import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes)
import Data.Ord (comparing)
import Data.Char (toLower, isSpace)
import Control.Monad
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as S
import Network.HTTP (urlEncodeVars)
import Data.Time (getCurrentTime, addUTCTime)
import Data.Time.Clock (diffUTCTime, UTCTime(..))
import Data.FileStore
import System.Log.Logger (logM, Priority(..))

handleAny :: Handler
handleAny :: Handler
handleAny = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> (String -> Handler) -> Handler
forall (m :: * -> *) a. ServerMonad m => (String -> m a) -> m a
uriRest ((String -> Handler) -> Handler) -> (String -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \String
uri ->
  let path' :: String
path' = String -> String
uriPath String
uri
  in  do fs <- GititServerPart FileStore
getFileStore
         let rev = Params -> Maybe String
pRevision Params
params
         mimetype <- getMimeTypeForExtension
                      (takeExtension path')
         res <- liftIO $ E.try
                (retrieve fs path' rev :: IO B.ByteString)
         case res of
                Right ByteString
contents -> ServerPartT (ReaderT WikiState IO) ()
forall a (m :: * -> *). FilterMonad a m => m ()
ignoreFilters ServerPartT (ReaderT WikiState IO) () -> Handler -> Handler
forall a b.
ServerPartT (ReaderT WikiState IO) a
-> ServerPartT (ReaderT WikiState IO) b
-> ServerPartT (ReaderT WikiState IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  -- don't compress
                                  (Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response -> Response
setContentType String
mimetype (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
                                    (Html -> Response
forall a. ToMessage a => a -> Response
toResponse Html
noHtml) {rsBody = contents})
                                    -- ugly hack
                Left FileStoreError
NotFound  -> Handler
forall a. ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                Left FileStoreError
e         -> String -> Handler
forall a. HasCallStack => String -> a
error (FileStoreError -> String
forall a. Show a => a -> String
show FileStoreError
e)

debugHandler :: Handler
debugHandler :: Handler
debugHandler = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  req <- ServerPartT (ReaderT WikiState IO) Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  liftIO $ logM "gitit" DEBUG (show req)
  page <- getPage
  liftIO $ logM "gitit" DEBUG $ "Page = '" ++ page ++ "'\n" ++
              show params
  mzero

randomPage :: Handler
randomPage :: Handler
randomPage = do
  fs <- GititServerPart FileStore
getFileStore
  base' <- getWikiBase
  prunedFiles <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
  let pages = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
dropExtension [String]
prunedFiles
  if null pages
     then error "No pages found!"
     else do
       secs <- liftIO (fmap utctDayTime getCurrentTime)
       let newPage = [String]
pages [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!!
                     (DiffTime -> Int
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (DiffTime
secs DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1000000) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pages)
       seeOther (base' ++ urlForPage newPage) $ toResponse $
         p << "Redirecting to a random page"

discussPage :: Handler
discussPage :: Handler
discussPage = do
  page <- GititServerPart String
getPage
  base' <- getWikiBase
  seeOther (base' ++ urlForPage (if isDiscussPage page then page else ('@':page))) $
                     toResponse "Redirecting to discussion page"

createPage :: Handler
createPage :: Handler
createPage = do
  page <- GititServerPart String
getPage
  base' <- getWikiBase
  case page of
       (Char
'_':String
_) -> Handler
forall a. ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero   -- don't allow creation of _index, etc.
       String
_       -> PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                                      pgPageName = page
                                    , pgTabs = []
                                    , pgTitle = "Create " ++ page ++ "?"
                                    } (Html -> Handler) -> Html -> Handler
forall a b. (a -> b) -> a -> b
$
                    (Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> Html
stringToHtml
                        (String
"There is no page named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. You can:"))
                        Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                    ([Html] -> Html
forall a. HTML a => [a] -> Html
unordList ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
                      [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
                            [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_edit" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                              (String
"Create the page '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
                      , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
                            [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_search?" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                ([(String, String)] -> String
urlEncodeVars [(String
"patterns", String
page)])] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                              (String
"Search for pages containing the text '" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")])

uploadForm :: Handler
uploadForm :: Handler
uploadForm = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  let origPath :: String
origPath = Params -> String
pFilename Params
params
  let wikiname :: String
wikiname = Params -> String
pWikiname Params
params String -> String -> String
forall a. [a] -> [a] -> [a]
`orIfNull` String -> String
takeFileName String
origPath
  let logMsg :: String
logMsg = Params -> String
pLogMsg Params
params
  let upForm :: Html
upForm = Html -> Html
form (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
X.method String
"post", String -> HtmlAttr
enctype String
"multipart/form-data"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
       Html -> Html
fieldset (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
       [ Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"file"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"File to upload:"
              , Html
br
              , String -> Html
afile String
"file" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
value String
origPath] ]
       , Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"wikiname"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Name on wiki, including extension"
              , Html -> Html
noscript (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
" (leave blank to use the same filename)"
              , String -> Html
stringToHtml String
":"
              , Html
br
              , String -> Html
textfield String
"wikiname" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
value String
wikiname]
              , String -> Html
primHtmlChar String
"nbsp"
              , String -> String -> Html
checkbox String
"overwrite" String
"yes"
              , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"overwrite"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Overwrite existing file" ]
       , Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"logMsg"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Description of content or changes:"
              , Html
br
              , String -> Html
textfield String
"logMsg" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"60", String -> HtmlAttr
value String
logMsg]
              , String -> String -> Html
submit String
"upload" String
"Upload" ]
       ]
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                   pgMessages = pMessages params,
                   pgScripts = ["uploadForm.js"],
                   pgShowPageTools = False,
                   pgTabs = [],
                   pgTitle = "Upload a file"} Html
upForm

uploadFile :: Handler
uploadFile :: Handler
uploadFile = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  let origPath :: String
origPath = Params -> String
pFilename Params
params
  let filePath :: String
filePath = Params -> String
pFilePath Params
params
  let wikiname :: String
wikiname = String -> String
normalise
                 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/')
                 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Params -> String
pWikiname Params
params String -> String -> String
forall a. [a] -> [a] -> [a]
`orIfNull` String -> String
takeFileName String
origPath
  let logMsg :: String
logMsg = Params -> String
pLogMsg Params
params
  cfg <- GititServerPart Config
getConfig
  wPF <- isPageFile wikiname
  mbUser <- getLoggedInUser
  (user, email) <- case mbUser of
                        Maybe User
Nothing -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Anonymous", String
"")
                        Just User
u  -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> String
uUsername User
u, User -> String
uEmail User
u)
  let overwrite = Params -> Bool
pOverwrite Params
params
  fs <- getFileStore
  exists <- liftIO $ E.catch (latest fs wikiname >> return True) $ \FileStoreError
e ->
                      if FileStoreError
e FileStoreError -> FileStoreError -> Bool
forall a. Eq a => a -> a -> Bool
== FileStoreError
NotFound
                         then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         else FileStoreError -> IO (ZonkAny 0)
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO FileStoreError
e IO (ZonkAny 0) -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  let inStaticDir = Config -> String
staticDir Config
cfg String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Config -> String
repositoryPath Config
cfg String -> String -> String
</> String
wikiname)
  let inTemplatesDir = Config -> String
templatesDir Config
cfg String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Config -> String
repositoryPath Config
cfg String -> String -> String
</> String
wikiname)
  let dirs' = String -> [String]
splitDirectories (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
wikiname
  let imageExtensions = [String
".png", String
".jpg", String
".gif"]
  let errors = [(Bool, String)] -> [String]
validate
                 [ (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
logMsg,
                    String
"Description cannot be empty.")
                 , (String
".." String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
dirs', String
"Wikiname cannot contain '..'")
                 , (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
origPath, String
"File not found.")
                 , (Bool
inStaticDir,  String
"Destination is inside static directory.")
                 , (Bool
inTemplatesDir,  String
"Destination is inside templates directory.")
                 , (Bool -> Bool
not Bool
overwrite Bool -> Bool -> Bool
&& Bool
exists, String
"A file named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wikiname String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
"' already exists in the repository: choose a new name " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
"or check the box to overwrite the existing file.")
                 , (Bool
wPF,
                    String
"This file extension is reserved for wiki pages.")
                 ]
  if null errors
     then do
       expireCachedFile wikiname `mplus` return ()
       fileContents <- liftIO $ B.readFile filePath
       let len = ByteString -> Int64
B.length ByteString
fileContents
       liftIO $ save fs wikiname (Author user email) logMsg fileContents
       let contents = Html -> Html
thediv (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
             [ Html -> Html
h2 (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Uploaded " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
len String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes")
             , if String -> String
takeExtension String
wikiname String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
imageExtensions
                  then Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"To add this image to a page, use:" Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                       Html -> Html
pre (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"![alt text](/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wikiname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
                  else Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"To link to this resource from a page, use:" Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                       Html -> Html
pre (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"[link label](/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wikiname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") ]
       formattedPage defaultPageLayout{
                       pgMessages = pMessages params,
                       pgShowPageTools = False,
                       pgTabs = [],
                       pgTitle = "Upload successful"}
                     contents
     else withMessages errors uploadForm

goToPage :: Handler
goToPage :: Handler
goToPage = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  let gotopage :: String
gotopage = Params -> String
pGotoPage Params
params
  fs <- GititServerPart FileStore
getFileStore
  pruned_files <- liftIO (index fs) >>= filterM isPageFile
  let allPageNames = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
dropExtension [String]
pruned_files
  let findPage String -> Bool
f = (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
f [String]
allPageNames
  let exactMatch String
f = String
gotopage String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f
  let insensitiveMatch String
f = ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
gotopage) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
f)
  let prefixMatch String
f = ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
gotopage) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
f)
  base' <- getWikiBase
  case findPage exactMatch of
       Just String
m  -> String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
m) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse
                     String
"Redirecting to exact match"
       Maybe String
Nothing -> case (String -> Bool) -> Maybe String
findPage String -> Bool
insensitiveMatch of
                       Just String
m  -> String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
m) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse
                                    String
"Redirecting to case-insensitive match"
                       Maybe String
Nothing -> case (String -> Bool) -> Maybe String
findPage String -> Bool
prefixMatch of
                                       Just String
m  -> String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
m) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$
                                                  String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Redirecting" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                    String
" to partial match"
                                       Maybe String
Nothing -> Handler
searchResults

searchResults :: Handler
searchResults :: Handler
searchResults = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  let patterns :: [String]
patterns = Params -> [String]
pPatterns Params
params [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
`orIfNull` [Params -> String
pGotoPage Params
params]
  fs <- GititServerPart FileStore
getFileStore
  matchLines <- if null patterns
                   then return []
                   else liftIO $ E.catch (search fs SearchQuery{
                                                  queryPatterns = patterns
                                                , queryWholeWords = True
                                                , queryMatchAll = True
                                                , queryIgnoreCase = True })
                                       -- catch error, because newer versions of git
                                       -- return 1 on no match, and filestore <=0.3.3
                                       -- doesn't handle this properly:
                                       (\(FileStoreError
_ :: FileStoreError)  -> [SearchMatch] -> IO [SearchMatch]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
  let contentMatches = (SearchMatch -> String) -> [SearchMatch] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SearchMatch -> String
matchResourceName [SearchMatch]
matchLines
  allPages <- liftIO (index fs) >>= filterM isPageFile
  let slashToSpace = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then Char
' ' else Char
c)
  let inPageName String
pageName' String
x = String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
slashToSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
pageName')
  let matchesPatterns String
pageName' = Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
patterns) Bool -> Bool -> Bool
&&
       (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> String -> Bool
inPageName ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
pageName')) ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) [String]
patterns)
  let pageNameMatches = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
matchesPatterns [String]
allPages
  prunedFiles <- filterM isPageFile (contentMatches ++ pageNameMatches)
  let allMatchedFiles = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
prunedFiles
  let matchesInFile String
f =  (SearchMatch -> Maybe String) -> [SearchMatch] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SearchMatch
x -> if SearchMatch -> String
matchResourceName SearchMatch
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f
                                            then String -> Maybe String
forall a. a -> Maybe a
Just (SearchMatch -> String
matchLine SearchMatch
x)
                                            else Maybe String
forall a. Maybe a
Nothing) [SearchMatch]
matchLines
  let matches = (String -> (String, [String])) -> [String] -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
map (\String
f -> (String
f, String -> [String]
matchesInFile String
f)) [String]
allMatchedFiles
  let relevance (String
f, t a
ms) = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ms Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if String
f String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
pageNameMatches
                                         then Int
100
                                         else Int
0
  let preamble = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
patterns
                    then Html -> Html
h3 (Html -> Html) -> [String] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String
"Please enter a search term."]
                    else Html -> Html
h3 (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml (Int -> String
forall a. Show a => a -> String
show ([(String, [String])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [String])]
matches) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matches found for ")
                               , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"pattern"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unwords [String]
patterns]
  base' <- getWikiBase
  let toMatchListItem (String
file, [String]
contents) = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> String
dropExtension String
file)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> String
dropExtension String
file
        , String -> Html
stringToHtml (String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
contents) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matching lines)")
        , String -> Html
stringToHtml String
" "
        , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href String
"#", String -> HtmlAttr
theclass String
"showmatch",
                    String -> HtmlAttr
thestyle String
"display: none;"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
contents Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                                                     then String
"[show matches]"
                                                     else String
""
        , Html -> Html
pre (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"matches"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
contents]
  let htmlMatches = Html
preamble Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                    Html -> Html
olist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< ((String, [String]) -> Html) -> [(String, [String])] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (String, [String]) -> Html
toMatchListItem
                             ([(String, [String])] -> [(String, [String])]
forall a. [a] -> [a]
reverse ([(String, [String])] -> [(String, [String])])
-> [(String, [String])] -> [(String, [String])]
forall a b. (a -> b) -> a -> b
$ ((String, [String]) -> (String, [String]) -> Ordering)
-> [(String, [String])] -> [(String, [String])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, [String]) -> Int)
-> (String, [String]) -> (String, [String]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (String, [String]) -> Int
forall {t :: * -> *} {a}. Foldable t => (String, t a) -> Int
relevance) [(String, [String])]
matches)
  formattedPage defaultPageLayout{
                  pgMessages = pMessages params,
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgScripts = ["search.js"],
                  pgTitle = "Search results"}
                htmlMatches

showPageHistory :: Handler
showPageHistory :: Handler
showPageHistory = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  page <- GititServerPart String
getPage
  cfg <- getConfig
  showHistory (pathForPage page $ defaultExtension cfg) page params

showFileHistory :: Handler
showFileHistory :: Handler
showFileHistory = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  file <- GititServerPart String
getPage
  showHistory file file params

showHistory :: String -> String -> Params -> Handler
showHistory :: String -> String -> Params -> Handler
showHistory String
file String
page Params
params =  do
  fs <- GititServerPart FileStore
getFileStore
  hist <- liftIO $ history fs [file] (TimeRange Nothing Nothing)
            (Just $ pLimit params)
  base' <- getWikiBase
  let versionToHtml Revision
rev Int
pos = Html -> Html
li (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"difflink", String -> Int -> HtmlAttr
intAttr String
"order" Int
pos,
                                    String -> String -> HtmlAttr
strAttr String
"revision" (Revision -> String
revId Revision
rev),
                                    String -> String -> HtmlAttr
strAttr String
"diffurl" (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
page)] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"date"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ Revision -> UTCTime
revDateTime Revision
rev)
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"author"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_activity?" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            [(String, String)] -> String
urlEncodeVars [(String
"forUser", Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)]] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
              (Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)
        , String -> Html
stringToHtml String
"): "
        , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?revision=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Revision -> String
revId Revision
rev)] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
           Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"subject"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<  Revision -> String
revDescription Revision
rev
        , Html -> Html
noscript (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            ([ String -> Html
stringToHtml String
" [compare with "
             , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?to=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Revision -> String
revId Revision
rev] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                  String
"previous" ] [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             (if Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
                  then [ String -> Html
primHtmlChar String
"nbsp"
                       , String -> Html
primHtmlChar String
"bull"
                       , String -> Html
primHtmlChar String
"nbsp"
                       , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?from=" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                  Revision -> String
revId Revision
rev] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"current"
                       ]
                  else []) [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             [String -> Html
stringToHtml String
"]"])
        ]
  let contents = if [Revision] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Revision]
hist
                    then Html
noHtml
                    else Html -> Html
ulist (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"history"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                           (Revision -> Int -> Html) -> [Revision] -> [Int] -> [Html]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Revision -> Int -> Html
versionToHtml [Revision]
hist
                           [[Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist, ([Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)..Int
1]
  let more = if [Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Params -> Int
pLimit Params
params
                then Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_history" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?limit=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Params -> Int
pLimit Params
params Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                                 String
"Show more..."
                else Html
noHtml
  let tabs = if String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
page  -- source file, not wiki page
                then [Tab
ViewTab,Tab
HistoryTab]
                else PageLayout -> [Tab]
pgTabs PageLayout
defaultPageLayout
  formattedPage defaultPageLayout{
                   pgPageName = page,
                   pgMessages = pMessages params,
                   pgScripts = ["dragdiff.js"],
                   pgTabs = tabs,
                   pgSelectedTab = HistoryTab,
                   pgTitle = ("Changes to " ++ page)
                   } $ contents +++ more

showActivity :: Handler
showActivity :: Handler
showActivity = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  cfg <- GititServerPart Config
getConfig
  currTime <- liftIO getCurrentTime
  let defaultDaysAgo = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Config -> Int
recentActivityDays Config
cfg)
  let daysAgo = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
defaultDaysAgo NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* (-NominalDiffTime
60) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
24) UTCTime
currTime
  let since = case Params -> Maybe UTCTime
pSince Params
params of
                   Maybe UTCTime
Nothing -> UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
daysAgo
                   Just UTCTime
t  -> UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t
  let forUser = Params -> Maybe String
pForUser Params
params
  fs <- getFileStore
  hist <- liftIO $ history fs [] (TimeRange since Nothing)
                     (Just $ pLimit params)
  let hist' = case Maybe String
forUser of
                   Maybe String
Nothing -> [Revision]
hist
                   Just String
u  -> (Revision -> Bool) -> [Revision] -> [Revision]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Revision
r -> Author -> String
authorName (Revision -> Author
revAuthor Revision
r) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
u) [Revision]
hist
  let fileFromChange (Added String
f)    = String
f
      fileFromChange (Modified String
f) = String
f
      fileFromChange (Deleted String
f)  = String
f
  base' <- getWikiBase
  let fileAnchor String
revis String
file = if String -> String
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Config -> String
defaultExtension Config
cfg)
        then Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> String
dropExtension String
file) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?to=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
revis] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> String
dropExtension String
file
        else Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?revision=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
revis] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
file
  let filesFor [Change]
changes String
revis = Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse (String -> Html
stringToHtml String
" ") ([Html] -> [Html]) -> [Html] -> [Html]
forall a b. (a -> b) -> a -> b
$
        (Change -> Html) -> [Change] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Html
fileAnchor String
revis (String -> Html) -> (Change -> String) -> Change -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Change -> String
fileFromChange) [Change]
changes
  let heading = Html -> Html
h1 (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Recent changes by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"all users" Maybe String
forUser)
  let revToListItem Revision
rev = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"date"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ Revision -> UTCTime
revDateTime Revision
rev)
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"author"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_activity?" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              [(String, String)] -> String
urlEncodeVars [(String
"forUser", Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)]] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                (Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)
        , String -> Html
stringToHtml String
"): "
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"subject"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Revision -> String
revDescription Revision
rev
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"files"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Change] -> String -> [Html]
filesFor (Revision -> [Change]
revChanges Revision
rev) (Revision -> String
revId Revision
rev)
        , String -> Html
stringToHtml String
")"
        ]
  let contents = Html -> Html
ulist (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"history"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (Revision -> Html) -> [Revision] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Revision -> Html
revToListItem [Revision]
hist'
  formattedPage defaultPageLayout{
                  pgMessages = pMessages params,
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgTitle = "Recent changes"
                  } (heading +++ contents)

showPageDiff :: Handler
showPageDiff :: Handler
showPageDiff = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  page <- GititServerPart String
getPage
  cfg <- getConfig
  showDiff (pathForPage page $ defaultExtension cfg) page params

showFileDiff :: Handler
showFileDiff :: Handler
showFileDiff = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  page <- GititServerPart String
getPage
  showDiff page page params

showDiff :: String -> String -> Params -> Handler
showDiff :: String -> String -> Params -> Handler
showDiff String
file String
page Params
params = do
  let from :: Maybe String
from = Params -> Maybe String
pFrom Params
params
  let to :: Maybe String
to = Params -> Maybe String
pTo Params
params
  -- 'to' or 'from' must be given
  Bool
-> ServerPartT (ReaderT WikiState IO) ()
-> ServerPartT (ReaderT WikiState IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String
from Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Maybe String
to Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
forall a. Maybe a
Nothing) ServerPartT (ReaderT WikiState IO) ()
forall a. ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  fs <- GititServerPart FileStore
getFileStore
  -- if 'to' is not specified, defaults to current revision
  -- if 'from' is not specified, defaults to revision immediately before 'to'
  from' <- case (from, to) of
              (Just String
_, Maybe String
_)        -> Maybe String -> ServerPartT (ReaderT WikiState IO) (Maybe String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
from
              (Maybe String
Nothing, Maybe String
Nothing) -> Maybe String -> ServerPartT (ReaderT WikiState IO) (Maybe String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
from
              (Maybe String
Nothing, Just String
t)  -> do
                pageHist <- IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision])
-> IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall a b. (a -> b) -> a -> b
$ FileStore -> [String] -> TimeRange -> Maybe Int -> IO [Revision]
history FileStore
fs [String
file]
                                     (Maybe UTCTime -> Maybe UTCTime -> TimeRange
TimeRange Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing)
                                     Maybe Int
forall a. Maybe a
Nothing
                let (_, upto) = break (\Revision
r -> FileStore -> String -> String -> Bool
idsMatch FileStore
fs (Revision -> String
revId Revision
r) String
t)
                                  pageHist
                return $ if length upto >= 2
                            -- immediately preceding revision
                            then Just $ revId $ upto !! 1
                            else Nothing
  result' <- liftIO $ E.try $ getDiff fs file from' to
  case result' of
       Left FileStoreError
NotFound  -> Handler
forall a. ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Left FileStoreError
e         -> IO Response -> Handler
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> Handler) -> IO Response -> Handler
forall a b. (a -> b) -> a -> b
$ FileStoreError -> IO Response
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO FileStoreError
e
       Right Html
htmlDiff -> PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                                          pgPageName = page,
                                          pgRevision = from' `mplus` to,
                                          pgMessages = pMessages params,
                                          pgTabs = DiffTab :
                                                   pgTabs defaultPageLayout,
                                          pgSelectedTab = DiffTab,
                                          pgTitle = page
                                          }
                                       Html
htmlDiff

getDiff :: FileStore -> FilePath -> Maybe RevisionId -> Maybe RevisionId
        -> IO Html
getDiff :: FileStore -> String -> Maybe String -> Maybe String -> IO Html
getDiff FileStore
fs String
file Maybe String
from Maybe String
to = do
  rawDiff <- FileStore
-> String -> Maybe String -> Maybe String -> IO [Diff [String]]
diff FileStore
fs String
file Maybe String
from Maybe String
to
  let diffLineToHtml (Both [String]
xs [String]
_) = Html -> Html
thespan (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
      diffLineToHtml (First [String]
xs) = Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"deleted"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
      diffLineToHtml (Second [String]
xs) = Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"added"]  (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
  return $ h2 ! [theclass "revision"] <<
             ("Changes from " ++ fromMaybe "beginning" from ++
              " to " ++ fromMaybe "current" to) +++
           pre ! [theclass "diff"] << map diffLineToHtml rawDiff

editPage :: Handler
editPage :: Handler
editPage = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
editPage'

editPage' :: Params -> Handler
editPage' :: Params -> Handler
editPage' Params
params = do
  let rev :: Maybe String
rev = Params -> Maybe String
pRevision Params
params  -- if this is set, we're doing a revert
  fs <- GititServerPart FileStore
getFileStore
  page <- getPage
  cfg <- getConfig
  let getRevisionAndText = IO (Maybe String, String)
-> (FileStoreError -> IO (Maybe String, String))
-> IO (Maybe String, String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
        (do c <- IO String -> IO String
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ FileStore -> forall a. Contents a => String -> Maybe String -> IO a
retrieve FileStore
fs (String -> String -> String
pathForPage String
page (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg) Maybe String
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 $ defaultExtension cfg) >>= revision fs
            return (Just $ revId r, c))
        (\FileStoreError
e -> if FileStoreError
e FileStoreError -> FileStoreError -> Bool
forall a. Eq a => a -> a -> Bool
== FileStoreError
NotFound
                  then (Maybe String, String) -> IO (Maybe String, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, String
"")
                  else FileStoreError -> IO (Maybe String, String)
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO FileStoreError
e)
  (mbRev, raw) <- case pEditedText params of
                         Maybe String
Nothing -> IO (Maybe String, String)
-> ServerPartT (ReaderT WikiState IO) (Maybe String, String)
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe String, String)
getRevisionAndText
                         Just String
t  -> let r :: Maybe String
r = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Params -> String
pSHA1 Params
params)
                                               then Maybe String
forall a. Maybe a
Nothing
                                               else String -> Maybe String
forall a. a -> Maybe a
Just (Params -> String
pSHA1 Params
params)
                                    in (Maybe String, String)
-> ServerPartT (ReaderT WikiState IO) (Maybe String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
r, String
t)
  let messages = Params -> [String]
pMessages Params
params
  let logMsg = Params -> String
pLogMsg Params
params
  let sha1Box = case Maybe String
mbRev of
                 Just String
r  -> String -> Html
textfield String
"sha1" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle String
"display: none",
                                                String -> HtmlAttr
value String
r]
                 Maybe String
Nothing -> Html
noHtml
  let readonly = if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Params -> Maybe String
pRevision Params
params)
                    -- disable editing of text box if it's a revert
                    then [String -> String -> HtmlAttr
strAttr String
"readonly" String
"yes",
                          String -> String -> HtmlAttr
strAttr String
"style" String
"color: gray"]
                    else []
  base' <- getWikiBase
  let editForm = String -> Html -> Html
gui (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page) (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"editform"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                   [ Html
sha1Box
                   , Html -> Html
textarea (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([HtmlAttr]
readonly [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [String -> HtmlAttr
cols String
"80", String -> HtmlAttr
name String
"editedText",
                                  String -> HtmlAttr
identifier String
"editedText"]) (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
raw
                   , Html
br
                   , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"logMsg"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Description of changes:"
                   , Html
br
                   , String -> Html
textfield String
"logMsg" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([HtmlAttr]
readonly [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [String -> HtmlAttr
value (String
logMsg String -> String -> String
forall a. [a] -> [a] -> [a]
`orIfNull` Config -> String
defaultSummary Config
cfg) ])
                   , String -> String -> Html
submit String
"update" String
"Save"
                   , String -> Html
primHtmlChar String
"nbsp"
                   , String -> String -> Html
submit String
"cancel" String
"Discard"
                   , String -> Html
primHtmlChar String
"nbsp"
                   , Html
input Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thetype String
"button", String -> HtmlAttr
theclass String
"editButton",
                              String -> HtmlAttr
identifier String
"previewButton",
                              String -> String -> HtmlAttr
strAttr String
"onClick" String
"updatePreviewPane();",
                              String -> String -> HtmlAttr
strAttr String
"style" String
"display: none;",
                              String -> HtmlAttr
value String
"Preview" ]
                   , Html -> Html
thediv (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
identifier String
"previewpane" ] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
                   ]
  let pgScripts' = [String
"preview.js"]
  let pgScripts'' = case Config -> MathMethod
mathMethod Config
cfg of
       MathMethod
MathML       -> String
"MathMLinHTML.js" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pgScripts'
       MathJax String
url  -> String
url String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pgScripts'
       MathMethod
_            -> [String]
pgScripts'
  formattedPage defaultPageLayout{
                  pgPageName = page,
                  pgMessages = messages,
                  pgRevision = rev,
                  pgShowPageTools = False,
                  pgShowSiteNav = False,
                  pgMarkupHelp = Just $ markupHelp cfg,
                  pgSelectedTab = EditTab,
                  pgScripts = pgScripts'',
                  pgTitle = ("Editing " ++ page)
                  } editForm

confirmDelete :: Handler
confirmDelete :: Handler
confirmDelete = do
  page <- GititServerPart String
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 $ defaultExtension cfg)
  fileToDelete <- case pageTest of
                       Right String
_        -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GititServerPart String)
-> String -> GititServerPart String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
pathForPage String
page (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg -- a page
                       Left  FileStoreError
NotFound -> do
                         fileTest <- IO (Either FileStoreError String)
-> ServerPartT
     (ReaderT WikiState IO) (Either FileStoreError String)
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FileStoreError String)
 -> ServerPartT
      (ReaderT WikiState IO) (Either FileStoreError String))
-> IO (Either FileStoreError String)
-> ServerPartT
     (ReaderT WikiState IO) (Either FileStoreError String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either FileStoreError String)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO String -> IO (Either FileStoreError String))
-> IO String -> IO (Either FileStoreError String)
forall a b. (a -> b) -> a -> b
$ FileStore -> String -> IO String
latest FileStore
fs String
page
                         case fileTest of
                              Right String
_       -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
page  -- a source file
                              Left FileStoreError
NotFound -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                              Left FileStoreError
e        -> String -> GititServerPart String
forall a. String -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (FileStoreError -> String
forall a. Show a => a -> String
show FileStoreError
e)
                       Left FileStoreError
e        -> String -> GititServerPart String
forall a. String -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (FileStoreError -> String
forall a. Show a => a -> String
show FileStoreError
e)
  let confirmForm = String -> Html -> Html
gui String
"" (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Are you sure you want to delete this page?"
        , Html
input Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thetype String
"text", String -> HtmlAttr
name String
"filetodelete",
                   String -> String -> HtmlAttr
strAttr String
"style" String
"display: none;", String -> HtmlAttr
value String
fileToDelete]
        , String -> String -> Html
submit String
"confirm" String
"Yes, delete it!"
        , String -> Html
stringToHtml String
" "
        , String -> String -> Html
submit String
"cancel" String
"No, keep it!"
        , Html
br ]
  formattedPage defaultPageLayout{ pgTitle = "Delete " ++ page ++ "?" } $
    if null fileToDelete
       then ulist ! [theclass "messages"] << li <<
            "There is no file or page by that name."
       else confirmForm

deletePage :: Handler
deletePage :: Handler
deletePage = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  page <- GititServerPart String
getPage
  cfg <- getConfig
  let file = Params -> String
pFileToDelete Params
params
  mbUser <- getLoggedInUser
  (user, email) <- case mbUser of
                        Maybe User
Nothing -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Anonymous", String
"")
                        Just User
u  -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> String
uUsername User
u, User -> String
uEmail User
u)
  let author = String -> String -> Author
Author String
user String
email
  let descrip = Config -> String
deleteSummary Config
cfg
  base' <- getWikiBase
  if pConfirm params && (file == page || file == page <.> (defaultExtension cfg))
     then do
       fs <- getFileStore
       liftIO $ Data.FileStore.delete fs file author descrip
       seeOther (base' ++ "/") $ toResponse $ p << "File deleted"
     else seeOther (base' ++ urlForPage page) $ toResponse $ p << "Not deleted"

updatePage :: Handler
updatePage :: Handler
updatePage = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  page <- GititServerPart String
getPage
  cfg <- getConfig
  mbUser <- getLoggedInUser
  (user, email) <- case mbUser of
                        Maybe User
Nothing -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Anonymous", String
"")
                        Just User
u  -> (String, String)
-> ServerPartT (ReaderT WikiState IO) (String, String)
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> String
uUsername User
u, User -> String
uEmail User
u)
  editedText <- case pEditedText params of
                     Maybe String
Nothing -> String -> GititServerPart String
forall a. HasCallStack => String -> a
error String
"No body text in POST request"
                     Just String
b  -> String -> GititServerPart String
applyPreCommitPlugins String
b
  let logMsg = Params -> String
pLogMsg Params
params String -> String -> String
forall a. [a] -> [a] -> [a]
`orIfNull` Config -> String
defaultSummary Config
cfg
  let oldSHA1 = Params -> String
pSHA1 Params
params
  fs <- getFileStore
  base' <- getWikiBase
  if null . filter (not . isSpace) $ logMsg
     then withMessages ["Description cannot be empty."] editPage
     else do
       when (length editedText > fromIntegral (maxPageSize cfg)) $
          error "Page exceeds maximum size."
       -- check SHA1 in case page has been modified, merge
       modifyRes <- if null oldSHA1
                       then liftIO $ create fs (pathForPage page $ defaultExtension cfg)
                                       (Author user email) logMsg editedText >>
                                     return (Right ())
                       else do
                         expireCachedFile (pathForPage page $ defaultExtension cfg) `mplus` return ()
                         liftIO $ E.catch (modify fs (pathForPage page $ defaultExtension cfg)
                                            oldSHA1 (Author user email) logMsg
                                            editedText)
                                     (\FileStoreError
e -> if FileStoreError
e FileStoreError -> FileStoreError -> Bool
forall a. Eq a => a -> a -> Bool
== FileStoreError
Unchanged
                                               then Either MergeInfo () -> IO (Either MergeInfo ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either MergeInfo ()
forall a b. b -> Either a b
Right ())
                                               else FileStoreError -> IO (Either MergeInfo ())
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO FileStoreError
e)
       case modifyRes of
            Right () -> String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> Response) -> Html -> Response
forall a b. (a -> b) -> a -> b
$ Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Page updated"
            Left (MergeInfo Revision
mergedWithRev Bool
conflicts String
mergedText) -> do
               let mergeMsg :: String
mergeMsg = String
"The page has been edited since you checked it out. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"Changes from revision " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Revision -> String
revId Revision
mergedWithRev String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
" have been merged into your edits below. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      if Bool
conflicts
                         then String
"Please resolve conflicts and Save."
                         else String
"Please review and Save."
               Params -> Handler
editPage' (Params -> Handler) -> Params -> Handler
forall a b. (a -> b) -> a -> b
$
                 Params
params{ pEditedText = Just mergedText,
                         pSHA1       = revId mergedWithRev,
                         pMessages   = [mergeMsg] }

indexPage :: Handler
indexPage :: Handler
indexPage = do
  path' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getPath
  base' <- getWikiBase
  cfg <- getConfig
  let ext = Config -> String
defaultExtension Config
cfg
  let prefix' = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then String
"" else String
path' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
  fs <- getFileStore
  listing <- liftIO $ directory fs prefix'
  let isNotDiscussionPage (FSFile String
f) = String -> ServerPartT (ReaderT WikiState IO) Bool
isNotDiscussPageFile String
f
      isNotDiscussionPage (FSDirectory String
_) = Bool -> ServerPartT (ReaderT WikiState IO) Bool
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  prunedListing <- filterM isNotDiscussionPage listing
  let htmlIndex = String -> String -> String -> [Resource] -> Html
fileListToHtml String
base' String
prefix' String
ext [Resource]
prunedListing
  formattedPage defaultPageLayout{
                  pgPageName = prefix',
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgScripts = [],
                  pgTitle = "Contents"} htmlIndex

fileListToHtml :: String -> String -> String -> [Resource] -> Html
fileListToHtml :: String -> String -> String -> [Resource] -> Html
fileListToHtml String
base' String
prefix String
ext [Resource]
files =
  let fileLink :: Resource -> Html
fileLink (FSFile String
f) | String -> String
takeExtension String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext =
        Html -> Html
li (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"page"  ] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
          Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
dropExtension String
f)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            String -> String
dropExtension String
f
      fileLink (FSFile String
f) = Html -> Html
li (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"upload"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
f
        , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_delete" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"(delete)"
        ]
      fileLink (FSDirectory String
f) =
        Html -> Html
li (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"folder"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
          Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
f
      updirs :: [[String]]
updirs = Int -> [[String]] -> [[String]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
forall a. [a] -> [[a]]
inits ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: String
prefix
      uplink :: Html
uplink = ([String] -> Html -> Html) -> Html -> [[String]] -> Html
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[String]
d Html
accum ->
                  [Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"updir",
                                         String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
                                                   then String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_index"
                                                   else String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                        String -> String
urlForPage ([String] -> String
joinPath ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
d)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                  String -> [String] -> String
forall a. HasCallStack => String -> [a] -> a
lastNote String
"fileListToHtml" [String]
d, Html
accum]) Html
noHtml [[String]]
updirs
  in Html
uplink Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html -> Html
ulist (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"index"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (Resource -> Html) -> [Resource] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Resource -> Html
fileLink [Resource]
files

-- NOTE:  The current implementation of categoryPage does not go via the
-- filestore abstraction.  That is bad, but can only be fixed if we add
-- more sophisticated searching options to filestore.
categoryPage :: Handler
categoryPage :: Handler
categoryPage = do
  path' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getPath
  cfg <- getConfig
  let pcategories = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') String
path'
  let repoPath = Config -> String
repositoryPath Config
cfg
  let categoryDescription = String
"Category: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" + " [String]
pcategories)
  fs <- getFileStore
  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
  matches <- liftM catMaybes $
             forM pages $ \String
f -> do
               categories <- IO [String] -> ServerPartT (ReaderT WikiState IO) [String]
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ServerPartT (ReaderT WikiState IO) [String])
-> IO [String] -> ServerPartT (ReaderT WikiState IO) [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
readCategories (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
repoPath String -> String -> String
</> String
f
               return $ if all ( `elem` categories) pcategories
                           then Just (f, categories \\ pcategories)
                           else Nothing
  base' <- getWikiBase
  let toMatchListItem String
file = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> String
dropExtension String
file)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> String
dropExtension String
file ]
  let toRemoveListItem String
cat = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< 
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++
        (if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
pcategories)
         then String
"/_categories"
         else String
"/_category" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
Data.List.delete String
cat [String]
pcategories)) ]
        (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat) ]
  let toAddListItem String
cat = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"/_category" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
path' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat) ]
        (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat) ]
  let matchList = Html -> Html
ulist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toMatchListItem (([String], [[String]]) -> [String]
forall a b. (a, b) -> a
fst (([String], [[String]]) -> [String])
-> ([String], [[String]]) -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, [String])] -> ([String], [[String]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, [String])]
matches) Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                  Html -> Html
thediv (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
identifier String
"categoryList" ] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                  Html -> Html
ulist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
(++) ((String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toAddListItem ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], [[String]]) -> [[String]]
forall a b. (a, b) -> b
snd (([String], [[String]]) -> [[String]])
-> ([String], [[String]]) -> [[String]]
forall a b. (a -> b) -> a -> b
$ [(String, [String])] -> ([String], [[String]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, [String])]
matches)) 
                                ((String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toRemoveListItem [String]
pcategories) 
  formattedPage defaultPageLayout{
                  pgPageName = categoryDescription,
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgScripts = ["search.js"],
                  pgTitle = categoryDescription }
                matchList

categoryListPage :: Handler
categoryListPage :: Handler
categoryListPage = do
  cfg <- GititServerPart Config
getConfig
  let repoPath = Config -> String
repositoryPath Config
cfg
  fs <- getFileStore
  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
  categories <- liftIO $ liftM (nub . sort . concat) $ forM pages $ \String
f ->
                  String -> IO [String]
readCategories (String
repoPath String -> String -> String
</> String
f)
  base' <- getWikiBase
  let toCatLink String
ctg = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_category" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
ctg] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
ctg ]
  let htmlMatches = Html -> Html
ulist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toCatLink [String]
categories
  formattedPage defaultPageLayout{
                  pgPageName = "Categories",
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgScripts = ["search.js"],
                  pgTitle = "Categories" } htmlMatches

expireCache :: Handler
expireCache :: Handler
expireCache = do
  page <- GititServerPart String
getPage
  cfg <- getConfig
  -- try it as a page first, then as an uploaded file
  expireCachedFile (pathForPage page $ defaultExtension cfg)
  expireCachedFile page
  ok $ toResponse ()

feedHandler :: Handler
feedHandler :: Handler
feedHandler = do
  cfg <- GititServerPart Config
getConfig
  when (not $ useFeed cfg) mzero
  base' <- getWikiBase
  feedBase <- if null (baseUrl cfg)  -- if baseUrl blank, try to get it from Host header
                 then do
                   mbHost <- getHost
                   case mbHost of
                        Maybe String
Nothing    -> String -> GititServerPart String
forall a. HasCallStack => String -> a
error String
"Could not determine base URL"
                        Just String
hn    -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GititServerPart String)
-> String -> GititServerPart String
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
base'
                 else case baseUrl cfg ++ base' of
                           w :: String
w@(Char
'h':Char
't':Char
't':Char
'p':Char
's':Char
':':Char
'/':Char
'/':String
_) -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
w
                           x :: String
x@(Char
'h':Char
't':Char
't':Char
'p':Char
':':Char
'/':Char
'/':String
_) -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
                           String
y                                 -> String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GititServerPart String)
-> String -> GititServerPart String
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y
  let fc = FeedConfig{
              fcTitle :: String
fcTitle = Config -> String
wikiTitle Config
cfg
            , fcBaseUrl :: String
fcBaseUrl = String
feedBase
            , fcFeedDays :: Integer
fcFeedDays = Config -> Integer
feedDays Config
cfg }
  path' <- getPath     -- e.g. "foo/bar" if they hit /_feed/foo/bar
  let file = (String
path' String -> String -> String
forall a. [a] -> [a] -> [a]
`orIfNull` String
"_site") String -> String -> String
<.> String
"feed"
  let mbPath = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
path'
  -- first, check for a cached version that is recent enough
  now <- liftIO getCurrentTime
  let isRecentEnough UTCTime
t = NominalDiffTime -> Integer
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
t) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Config -> Integer
feedRefreshTime Config
cfg
  mbCached <- lookupCache file
  case mbCached of
       Just (UTCTime
modtime, ByteString
contents) | UTCTime -> Bool
isRecentEnough UTCTime
modtime -> do
            let emptyResponse :: Response
emptyResponse = String -> Response -> Response
setContentType String
"application/atom+xml; charset=utf-8" (Response -> Response) -> (() -> Response) -> () -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Response
forall a. ToMessage a => a -> Response
toResponse (() -> Response) -> () -> Response
forall a b. (a -> b) -> a -> b
$ ()
            Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ Response
emptyResponse{rsBody = B.fromChunks [contents]}
       Maybe (UTCTime, ByteString)
_ -> do
            fs <- GititServerPart FileStore
getFileStore
            resp' <- liftM toResponse $ liftIO (filestoreToXmlFeed fc fs mbPath)
            cacheContents file $ S.concat $ B.toChunks $ rsBody resp'
            ok . setContentType "application/atom+xml; charset=UTF-8" $ resp'