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

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

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

discussPage :: Handler
discussPage :: Handler
discussPage = do
  String
page <- GititServerPart String
getPage
  String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (if String -> Bool
isDiscussPage String
page then String
page else (Char
'@'forall a. a -> [a] -> [a]
:String
page))) forall a b. (a -> b) -> a -> b
$
                     forall a. ToMessage a => a -> Response
toResponse String
"Redirecting to discussion page"

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

uploadForm :: Handler
uploadForm :: Handler
uploadForm = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData 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 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
X.method String
"post", String -> HtmlAttr
enctype String
"multipart/form-data"] forall a b. HTML a => (Html -> b) -> a -> b
<<
       Html -> Html
fieldset forall a b. HTML a => (Html -> b) -> a -> b
<<
       [ Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"file"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"File to upload:"
              , Html
br
              , String -> Html
afile String
"file" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
value String
origPath] ]
       , Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"wikiname"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Name on wiki, including extension"
              , Html -> Html
noscript 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" 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"overwrite"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Overwrite existing file" ]
       , Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"logMsg"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Description of content or changes:"
              , Html
br
              , String -> Html
textfield String
"logMsg" 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 :: [String]
pgMessages = Params -> [String]
pMessages Params
params,
                   pgScripts :: [String]
pgScripts = [String
"uploadForm.js"],
                   pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                   pgTabs :: [Tab]
pgTabs = [],
                   pgTitle :: String
pgTitle = String
"Upload a file"} Html
upForm

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

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

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

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

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

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

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

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

showFileDiff :: Handler
showFileDiff :: Handler
showFileDiff = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  String
page <- GititServerPart String
getPage
  String -> String -> Params -> Handler
showDiff String
page String
page Params
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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String
from forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Maybe String
to forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing) forall (m :: * -> *) a. MonadPlus m => m a
mzero
  FileStore
fs <- GititServerPart FileStore
getFileStore
  -- if 'to' is not specified, defaults to current revision
  -- if 'from' is not specified, defaults to revision immediately before 'to'
  Maybe String
from' <- case (Maybe String
from, Maybe String
to) of
              (Just String
_, Maybe String
_)        -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
from
              (Maybe String
Nothing, Maybe String
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
from
              (Maybe String
Nothing, Just String
t)  -> do
                [Revision]
pageHist <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
                                     forall a. Maybe a
Nothing
                let ([Revision]
_, [Revision]
upto) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\Revision
r -> FileStore -> String -> String -> Bool
idsMatch FileStore
fs (Revision -> String
revId Revision
r) String
t)
                                  [Revision]
pageHist
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
upto forall a. Ord a => a -> a -> Bool
>= Int
2
                            -- immediately preceding revision
                            then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Revision -> String
revId forall a b. (a -> b) -> a -> b
$ [Revision]
upto forall a. [a] -> Int -> a
!! Int
1
                            else forall a. Maybe a
Nothing
  Either FileStoreError Html
result' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ FileStore -> String -> Maybe String -> Maybe String -> IO Html
getDiff FileStore
fs String
file Maybe String
from' Maybe String
to
  case Either FileStoreError Html
result' of
       Left FileStoreError
NotFound  -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Left FileStoreError
e         -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO FileStoreError
e
       Right Html
htmlDiff -> PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                                          pgPageName :: String
pgPageName = String
page,
                                          pgRevision :: Maybe String
pgRevision = Maybe String
from' forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String
to,
                                          pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params,
                                          pgTabs :: [Tab]
pgTabs = Tab
DiffTab forall a. a -> [a] -> [a]
:
                                                   PageLayout -> [Tab]
pgTabs PageLayout
defaultPageLayout,
                                          pgSelectedTab :: Tab
pgSelectedTab = Tab
DiffTab,
                                          pgTitle :: String
pgTitle = String
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
  [Diff [String]]
rawDiff <- FileStore
-> String -> Maybe String -> Maybe String -> IO [Diff [String]]
diff FileStore
fs String
file Maybe String
from Maybe String
to
  let diffLineToHtml :: Diff [String] -> Html
diffLineToHtml (Both [String]
xs [String]
_) = Html -> Html
thespan forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
      diffLineToHtml (First [String]
xs) = Html -> Html
thespan forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"deleted"] forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
      diffLineToHtml (Second [String]
xs) = Html -> Html
thespan forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"added"]  forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> String
unlines [String]
xs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Html -> Html
h2 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"revision"] forall a b. HTML a => (Html -> b) -> a -> b
<<
             (String
"Changes from " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe String
"beginning" Maybe String
from forall a. [a] -> [a] -> [a]
++
              String
" to " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe String
"current" Maybe String
to) forall a b. (HTML a, HTML b) => a -> b -> Html
+++
           Html -> Html
pre forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"diff"] forall a b. HTML a => (Html -> b) -> a -> b
<< forall a b. (a -> b) -> [a] -> [b]
map Diff [String] -> Html
diffLineToHtml [Diff [String]]
rawDiff

editPage :: Handler
editPage :: Handler
editPage = 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
  FileStore
fs <- GititServerPart FileStore
getFileStore
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  let getRevisionAndText :: IO (Maybe String, String)
getRevisionAndText = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
        (do String
c <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 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)
            Revision
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FileStore -> String -> IO String
latest FileStore
fs (String -> String -> String
pathForPage String
page forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileStore -> String -> IO Revision
revision FileStore
fs
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Revision -> String
revId Revision
r, String
c))
        (\FileStoreError
e -> if FileStoreError
e forall a. Eq a => a -> a -> Bool
== FileStoreError
NotFound
                  then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, String
"")
                  else forall e a. Exception e => e -> IO a
E.throwIO FileStoreError
e)
  (Maybe String
mbRev, String
raw) <- case Params -> Maybe String
pEditedText Params
params of
                         Maybe String
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe String, String)
getRevisionAndText
                         Just String
t  -> let r :: Maybe String
r = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Params -> String
pSHA1 Params
params)
                                               then forall a. Maybe a
Nothing
                                               else forall a. a -> Maybe a
Just (Params -> String
pSHA1 Params
params)
                                    in forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
r, String
t)
  let messages :: [String]
messages = Params -> [String]
pMessages Params
params
  let logMsg :: String
logMsg = Params -> String
pLogMsg Params
params
  let sha1Box :: Html
sha1Box = case Maybe String
mbRev of
                 Just String
r  -> String -> Html
textfield String
"sha1" 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 :: [HtmlAttr]
readonly = if 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 []
  String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let editForm :: Html
editForm = String -> Html -> Html
gui (String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page) forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"editform"] forall a b. HTML a => (Html -> b) -> a -> b
<<
                   [ Html
sha1Box
                   , Html -> Html
textarea forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([HtmlAttr]
readonly forall a. [a] -> [a] -> [a]
++ [String -> HtmlAttr
cols String
"80", String -> HtmlAttr
name String
"editedText",
                                  String -> HtmlAttr
identifier String
"editedText"]) forall a b. HTML a => (Html -> b) -> a -> b
<< String
raw
                   , Html
br
                   , Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"logMsg"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Description of changes:"
                   , Html
br
                   , String -> Html
textfield String
"logMsg" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([HtmlAttr]
readonly forall a. [a] -> [a] -> [a]
++ [String -> HtmlAttr
value (String
logMsg 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 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
identifier String
"previewpane" ] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
                   ]
  let pgScripts' :: [String]
pgScripts' = [String
"preview.js"]
  let pgScripts'' :: [String]
pgScripts'' = case Config -> MathMethod
mathMethod Config
cfg of
       MathMethod
MathML       -> String
"MathMLinHTML.js" forall a. a -> [a] -> [a]
: [String]
pgScripts'
       MathJax String
url  -> String
url forall a. a -> [a] -> [a]
: [String]
pgScripts'
       MathMethod
_            -> [String]
pgScripts'
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgPageName :: String
pgPageName = String
page,
                  pgMessages :: [String]
pgMessages = [String]
messages,
                  pgRevision :: Maybe String
pgRevision = Maybe String
rev,
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgShowSiteNav :: Bool
pgShowSiteNav = Bool
False,
                  pgMarkupHelp :: Maybe Text
pgMarkupHelp = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Config -> Text
markupHelp Config
cfg,
                  pgSelectedTab :: Tab
pgSelectedTab = Tab
EditTab,
                  pgScripts :: [String]
pgScripts = [String]
pgScripts'',
                  pgTitle :: String
pgTitle = (String
"Editing " forall a. [a] -> [a] -> [a]
++ String
page)
                  } Html
editForm

confirmDelete :: Handler
confirmDelete :: Handler
confirmDelete = do
  String
page <- GititServerPart String
getPage
  FileStore
fs <- GititServerPart FileStore
getFileStore
  Config
cfg <- GititServerPart Config
getConfig
  -- determine whether there is a corresponding page, and if not whether there
  -- is a corresponding file
  Either FileStoreError String
pageTest <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ FileStore -> String -> IO String
latest FileStore
fs (String -> String -> String
pathForPage String
page forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg)
  String
fileToDelete <- case Either FileStoreError String
pageTest of
                       Right String
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> String
pathForPage String
page forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg -- a page
                       Left  FileStoreError
NotFound -> do
                         Either FileStoreError String
fileTest <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ FileStore -> String -> IO String
latest FileStore
fs String
page
                         case Either FileStoreError String
fileTest of
                              Right String
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return String
page  -- a source file
                              Left FileStoreError
NotFound -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                              Left FileStoreError
e        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show FileStoreError
e)
                       Left FileStoreError
e        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show FileStoreError
e)
  let confirmForm :: Html
confirmForm = String -> Html -> Html
gui String
"" forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Are you sure you want to delete this page?"
        , Html
input 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 ]
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{ pgTitle :: String
pgTitle = String
"Delete " forall a. [a] -> [a] -> [a]
++ String
page forall a. [a] -> [a] -> [a]
++ String
"?" } forall a b. (a -> b) -> a -> b
$
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fileToDelete
       then Html -> Html
ulist forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"messages"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
li forall a b. HTML a => (Html -> b) -> a -> b
<<
            String
"There is no file or page by that name."
       else Html
confirmForm

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

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

indexPage :: Handler
indexPage :: Handler
indexPage = do
  String
path' <- forall (m :: * -> *). ServerMonad m => m String
getPath
  String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  Config
cfg <- GititServerPart Config
getConfig
  let ext :: String
ext = Config -> String
defaultExtension Config
cfg
  let prefix' :: String
prefix' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then String
"" else String
path' forall a. [a] -> [a] -> [a]
++ String
"/"
  FileStore
fs <- GititServerPart FileStore
getFileStore
  [Resource]
listing <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FileStore -> String -> IO [Resource]
directory FileStore
fs String
prefix'
  let isNotDiscussionPage :: Resource -> GititServerPart Bool
isNotDiscussionPage (FSFile String
f) = String -> GititServerPart Bool
isNotDiscussPageFile String
f
      isNotDiscussionPage (FSDirectory String
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  [Resource]
prunedListing <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Resource -> GititServerPart Bool
isNotDiscussionPage [Resource]
listing
  let htmlIndex :: Html
htmlIndex = String -> String -> String -> [Resource] -> Html
fileListToHtml String
base' String
prefix' String
ext [Resource]
prunedListing
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgPageName :: String
pgPageName = String
prefix',
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgTabs :: [Tab]
pgTabs = [],
                  pgScripts :: [String]
pgScripts = [],
                  pgTitle :: String
pgTitle = String
"Contents"} Html
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 forall a. Eq a => a -> a -> Bool
== String
"." forall a. [a] -> [a] -> [a]
++ String
ext =
        Html -> Html
li forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"page"  ] forall a b. HTML a => (Html -> b) -> a -> b
<<
          Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix forall a. [a] -> [a] -> [a]
++ String -> String
dropExtension String
f)] forall a b. HTML a => (Html -> b) -> a -> b
<<
            String -> String
dropExtension String
f
      fileLink (FSFile String
f) = Html -> Html
li forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"upload"] forall a b. HTML a => (Html -> b) -> a -> b
<< forall a. HTML a => [a] -> Html
concatHtml
        [ Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix forall a. [a] -> [a] -> [a]
++ String
f)] forall a b. HTML a => (Html -> b) -> a -> b
<< String
f
        , Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String
"_delete" forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix forall a. [a] -> [a] -> [a]
++ String
f)] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"(delete)"
        ]
      fileLink (FSDirectory String
f) =
        Html -> Html
li forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"folder"] forall a b. HTML a => (Html -> b) -> a -> b
<<
          Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
prefix forall a. [a] -> [a] -> [a]
++ String
f) forall a. [a] -> [a] -> [a]
++ String
"/"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
f
      updirs :: [[String]]
updirs = forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
inits forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath forall a b. (a -> b) -> a -> b
$ Char
'/' forall a. a -> [a] -> [a]
: String
prefix
      uplink :: Html
uplink = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[String]
d Html
accum ->
                  forall a. HTML a => [a] -> Html
concatHtml [ Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"updir",
                                         String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
d forall a. Ord a => a -> a -> Bool
<= Int
1
                                                   then String
base' forall a. [a] -> [a] -> [a]
++ String
"/_index"
                                                   else String
base' forall a. [a] -> [a] -> [a]
++
                                                        String -> String
urlForPage ([String] -> String
joinPath forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [String]
d)] forall a b. HTML a => (Html -> b) -> a -> b
<<
                  forall a. HasCallStack => String -> [a] -> a
lastNote String
"fileListToHtml" [String]
d, Html
accum]) Html
noHtml [[String]]
updirs
  in Html
uplink forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html -> Html
ulist forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"index"] forall a b. HTML a => (Html -> b) -> a -> b
<< 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
  String
path' <- forall (m :: * -> *). ServerMonad m => m String
getPath
  Config
cfg <- GititServerPart Config
getConfig
  let pcategories :: [String]
pcategories = forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (forall a. Eq a => a -> a -> Bool
==Char
',') String
path'
  let repoPath :: String
repoPath = Config -> String
repositoryPath Config
cfg
  let categoryDescription :: String
categoryDescription = String
"Category: " forall a. [a] -> [a] -> [a]
++ (forall a. [a] -> [[a]] -> [a]
intercalate String
" + " [String]
pcategories)
  FileStore
fs <- GititServerPart FileStore
getFileStore
  [String]
pages <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FileStore -> IO [String]
index FileStore
fs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> GititServerPart Bool
isPageFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> GititServerPart Bool
isNotDiscussPageFile
  [(String, [String])]
matches <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
             forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pages forall a b. (a -> b) -> a -> b
$ \String
f -> do
               [String]
categories <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
readCategories forall a b. (a -> b) -> a -> b
$ String
repoPath String -> String -> String
</> String
f
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ( forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
categories) [String]
pcategories
                           then forall a. a -> Maybe a
Just (String
f, [String]
categories forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
pcategories)
                           else forall a. Maybe a
Nothing
  String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let toMatchListItem :: String -> Html
toMatchListItem String
file = Html -> Html
li forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> String
dropExtension String
file)] forall a b. HTML a => (Html -> b) -> a -> b
<< String -> String
dropExtension String
file ]
  let toRemoveListItem :: String -> Html
toRemoveListItem String
cat = Html -> Html
li forall a b. HTML a => (Html -> b) -> a -> b
<< 
        [ Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++
        (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. [a] -> [a]
tail [String]
pcategories)
         then String
"/_categories"
         else String
"/_category" forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> [a]
Data.List.delete String
cat [String]
pcategories)) ]
        forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"-" forall a. [a] -> [a] -> [a]
++ String
cat) ]
  let toAddListItem :: String -> Html
toAddListItem String
cat = Html -> Html
li forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++
          String
"/_category" forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String
path' forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ String
cat) ]
        forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"+" forall a. [a] -> [a] -> [a]
++ String
cat) ]
  let matchList :: Html
matchList = Html -> Html
ulist forall a b. HTML a => (Html -> b) -> a -> b
<< forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toMatchListItem (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [(String, [String])]
matches) forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                  Html -> Html
thediv forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
identifier String
"categoryList" ] forall a b. HTML a => (Html -> b) -> a -> b
<<
                  Html -> Html
ulist forall a b. HTML a => (Html -> b) -> a -> b
<< forall a. [a] -> [a] -> [a]
(++) (forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toAddListItem (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [(String, [String])]
matches)) 
                                (forall a b. (a -> b) -> [a] -> [b]
map String -> Html
toRemoveListItem [String]
pcategories) 
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgPageName :: String
pgPageName = String
categoryDescription,
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgTabs :: [Tab]
pgTabs = [],
                  pgScripts :: [String]
pgScripts = [String
"search.js"],
                  pgTitle :: String
pgTitle = String
categoryDescription }
                Html
matchList

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

expireCache :: Handler
expireCache :: Handler
expireCache = do
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  -- try it as a page first, then as an uploaded file
  String -> ServerPartT (ReaderT WikiState IO) ()
expireCachedFile (String -> String -> String
pathForPage String
page forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg)
  String -> ServerPartT (ReaderT WikiState IO) ()
expireCachedFile String
page
  forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()

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