{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-
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 Data.List (intercalate, intersperse, delete, nub, sortBy, find, isPrefixOf, inits, sort, (\\))
import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes)
import Data.Ord (comparing)
import Data.Char (toLower, isSpace)
import Control.Monad
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as S
import Network.HTTP (urlEncodeVars)
import Data.Time (getCurrentTime, addUTCTime)
import Data.Time.Clock (diffUTCTime, UTCTime(..))
import Data.FileStore
import System.Log.Logger (logM, Priority(..))
import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml )
import Text.Blaze.Html5 hiding (b, search, u, s, contents, source, html, title, map)
import Text.Blaze.Html5.Attributes hiding (span, id)
import qualified Text.Blaze.Html5 as Html5 hiding (search)
import qualified Text.Blaze.Html5.Attributes as Html5.Attr hiding (span)
import Data.String (IsString(fromString))
import Prelude hiding (span)

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

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

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

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

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

fileInput :: AttributeValue -> AttributeValue -> Html
fileInput :: AttributeValue -> AttributeValue -> Html
fileInput AttributeValue
nameAndId AttributeValue
val =  Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"file" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value AttributeValue
val
textfieldInput :: AttributeValue -> AttributeValue -> Html
textfieldInput :: AttributeValue -> AttributeValue -> Html
textfieldInput AttributeValue
nameAndId AttributeValue
val = Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"text" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value AttributeValue
val
checkboxInput :: AttributeValue -> AttributeValue -> Html
checkboxInput :: AttributeValue -> AttributeValue -> Html
checkboxInput AttributeValue
nameAndId AttributeValue
val = Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"checkbox" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value AttributeValue
val
submitInput :: AttributeValue -> AttributeValue -> Html
submitInput :: AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
nameAndId AttributeValue
val = Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"submit" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
nameAndId Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value AttributeValue
val

uploadForm :: Handler
uploadForm :: Handler
uploadForm = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
  let origPath :: [Char]
origPath = Params -> [Char]
pFilename Params
params
  let wikiname :: [Char]
wikiname = Params -> [Char]
pWikiname Params
params [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
`orIfNull` [Char] -> [Char]
takeFileName [Char]
origPath
  let logMsg :: [Char]
logMsg = Params -> [Char]
pLogMsg Params
params
  let upForm :: Html
upForm = Html -> Html
Html5.form (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.method AttributeValue
"post" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
enctype AttributeValue
"multipart/form-data"
       (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
fieldset (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
       [ Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
              [ Html -> Html
Html5.label (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
for AttributeValue
"file" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"File to upload:"
              , Html
br
              , AttributeValue -> AttributeValue -> Html
fileInput AttributeValue
"file" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
origPath) ]
       , Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
              [ Html -> Html
Html5.label (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
for AttributeValue
"wikiname" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Name on wiki, including extension"
              , Html -> Html
noscript (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
" (leave blank to use the same filename)"
              , Html
":"
              , Html
br
              , AttributeValue -> AttributeValue -> Html
textfieldInput AttributeValue
"wikiname" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
wikiname)
              , [Char] -> Html
preEscapedString [Char]
"&nbsp;"
              , AttributeValue -> AttributeValue -> Html
checkboxInput AttributeValue
"overwrite" AttributeValue
"yes"
              , Html -> Html
Html5.label (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
for AttributeValue
"overwrite" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Overwrite existing file"
              ]
       , Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
              [ Html -> Html
Html5.label (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
for AttributeValue
"logMsg" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Description of content or changes:"
              , Html
br
              , AttributeValue -> AttributeValue -> Html
textfieldInput AttributeValue
"logMsg" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
logMsg) Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
size AttributeValue
"60"
              , AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
"upload" AttributeValue
"Upload" ]
       ]
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                   pgMessages = pMessages params,
                   pgScripts = ["uploadForm.js"],
                   pgShowPageTools = False,
                   pgTabs = [],
                   pgTitle = "Upload a file"} Html
upForm

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

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

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

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

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

intDataAttribute :: Tag -> Int -> Attribute
intDataAttribute :: Tag -> Int -> Attribute
intDataAttribute Tag
tag = Tag -> AttributeValue -> Attribute
dataAttribute Tag
tag (AttributeValue -> Attribute)
-> (Int -> AttributeValue) -> Int -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show

showHistory :: String -> String -> Params -> Handler
showHistory :: [Char] -> [Char] -> Params -> Handler
showHistory [Char]
file [Char]
page Params
params =  do
  fs <- GititServerPart FileStore
getFileStore
  hist <- liftIO $ history fs [file] (TimeRange Nothing Nothing)
            (Just $ pLimit params)
  base' <- getWikiBase
  let versionToHtml Revision
rev Int
pos = Html -> Html
li (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"difflink" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> Int -> Attribute
intDataAttribute Tag
"order" Int
pos (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
!
                                    Tag -> AttributeValue -> Attribute
dataAttribute Tag
"revision" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Revision -> [Char]
revId Revision
rev) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
!
                                    Tag -> AttributeValue -> Attribute
dataAttribute Tag
"diffurl" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_diff/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
page)
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
        [ Html -> Html
span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"date" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ([Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show (UTCTime -> [Char]) -> UTCTime -> [Char]
forall a b. (a -> b) -> a -> b
$ Revision -> UTCTime
revDateTime Revision
rev)
        , Html
" ("
        , Html -> Html
span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"author" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_activity?" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            [([Char], [Char])] -> [Char]
urlEncodeVars [([Char]
"forUser", Author -> [Char]
authorName (Author -> [Char]) -> Author -> [Char]
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)]) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              [Char] -> Html
forall a. IsString a => [Char] -> a
fromString (Author -> [Char]
authorName (Author -> [Char]) -> Author -> [Char]
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)
        , Html
"): "
        , Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
page [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"?revision=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Revision -> [Char]
revId Revision
rev) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
           Html -> Html
span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"subject" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ Revision -> [Char]
revDescription Revision
rev
        , Html -> Html
noscript (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
            ([ Html
" [compare with "
             , Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_diff" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
page [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"?to=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Revision -> [Char]
revId Revision
rev) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                  Html
"previous" ] [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             (if Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
                  then [ [Char] -> Html
preEscapedString [Char]
"&nbsp;"
                       , [Char] -> Html
preEscapedString [Char]
"&bull;"
                       , [Char] -> Html
preEscapedString [Char]
"&nbsp;"
                       , Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_diff" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
page [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"?from=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                  Revision -> [Char]
revId Revision
rev) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"current"
                       ]
                  else []) [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             [Html
"]"])
        ]
  let contents = if [Revision] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Revision]
hist
                    then Html
forall a. Monoid a => a
mempty
                    else Html -> Html
ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"history" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
                           (Revision -> Int -> Html) -> [Revision] -> [Int] -> [Html]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Revision -> Int -> Html
versionToHtml [Revision]
hist
                           [[Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist, ([Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)..Int
1]
  let more = if [Revision] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Params -> Int
pLimit Params
params
                then Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_history" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
page
                                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"?limit=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Params -> Int
pLimit Params
params Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                                 Html
"Show more..."
                else Html
forall a. Monoid a => a
mempty
  let tabs = if [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
page  -- source file, not wiki page
                then [Tab
ViewTab,Tab
HistoryTab]
                else PageLayout -> [Tab]
pgTabs PageLayout
defaultPageLayout
  formattedPage defaultPageLayout{
                   pgPageName = page,
                   pgMessages = pMessages params,
                   pgScripts = ["dragdiff.js"],
                   pgTabs = tabs,
                   pgSelectedTab = HistoryTab,
                   pgTitle = ("Changes to " ++ page)
                   } $ contents <> more

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

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

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

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

getDiff :: FileStore -> FilePath -> Maybe RevisionId -> Maybe RevisionId
        -> IO Html
getDiff :: FileStore -> [Char] -> Maybe [Char] -> Maybe [Char] -> IO Html
getDiff FileStore
fs [Char]
file Maybe [Char]
from Maybe [Char]
to = do
  rawDiff <- FileStore
-> [Char] -> Maybe [Char] -> Maybe [Char] -> IO [Diff [[Char]]]
diff FileStore
fs [Char]
file Maybe [Char]
from Maybe [Char]
to
  let diffLineToHtml (Both [[Char]]
xs [[Char]]
_) = Html -> Html
span (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
xs
      diffLineToHtml (First [[Char]]
xs) = Html -> Html
span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"deleted" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
xs
      diffLineToHtml (Second [[Char]]
xs) = Html -> Html
span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"added"  (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
xs
  return $ h2 ! class_ "revision" $
            (fromString $ "Changes from " ++ fromMaybe "beginning" from ++
              " to " ++ fromMaybe "current" to) <>
           (pre ! class_ "diff" $ foldMap diffLineToHtml rawDiff)

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

gui :: AttributeValue -> Html -> Html
gui :: AttributeValue -> Html -> Html
gui AttributeValue
act = Html -> Html
Html5.form (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
action AttributeValue
act (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.method AttributeValue
"post"

editPage' :: Params -> Handler
editPage' :: Params -> Handler
editPage' Params
params = do
  let rev :: Maybe [Char]
rev = Params -> Maybe [Char]
pRevision Params
params  -- if this is set, we're doing a revert
  fs <- GititServerPart FileStore
getFileStore
  page <- getPage
  cfg <- getConfig
  let getRevisionAndText = IO (Maybe [Char], [Char])
-> (FileStoreError -> IO (Maybe [Char], [Char]))
-> IO (Maybe [Char], [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
        (do c <- IO [Char] -> IO [Char]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ FileStore -> forall a. Contents a => [Char] -> Maybe [Char] -> IO a
retrieve FileStore
fs ([Char] -> [Char] -> [Char]
pathForPage [Char]
page ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Config -> [Char]
defaultExtension Config
cfg) Maybe [Char]
rev
            -- even if pRevision is set, we return revId of latest
            -- saved version (because we're doing a revert and
            -- we don't want gitit to merge the changes with the
            -- latest version)
            r <- liftIO $ latest fs (pathForPage page $ defaultExtension cfg) >>= revision fs
            return (Just $ revId r, c))
        (\FileStoreError
e -> if FileStoreError
e FileStoreError -> FileStoreError -> Bool
forall a. Eq a => a -> a -> Bool
== FileStoreError
NotFound
                  then (Maybe [Char], [Char]) -> IO (Maybe [Char], [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
forall a. Maybe a
Nothing, [Char]
"")
                  else FileStoreError -> IO (Maybe [Char], [Char])
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO FileStoreError
e)
  (mbRev, raw) <- case pEditedText params of
                         Maybe [Char]
Nothing -> IO (Maybe [Char], [Char])
-> ServerPartT (ReaderT WikiState IO) (Maybe [Char], [Char])
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe [Char], [Char])
getRevisionAndText
                         Just [Char]
t  -> let r :: Maybe [Char]
r = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Params -> [Char]
pSHA1 Params
params)
                                               then Maybe [Char]
forall a. Maybe a
Nothing
                                               else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Params -> [Char]
pSHA1 Params
params)
                                    in (Maybe [Char], [Char])
-> ServerPartT (ReaderT WikiState IO) (Maybe [Char], [Char])
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
r, [Char]
t)
  let messages = Params -> [[Char]]
pMessages Params
params
  let logMsg = Params -> [Char]
pLogMsg Params
params
  let sha1Box = case Maybe [Char]
mbRev of
                 Just [Char]
r  -> AttributeValue -> AttributeValue -> Html
textfieldInput AttributeValue
"sha1" ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
r) Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.style AttributeValue
"display: none"
                 Maybe [Char]
Nothing -> Html
forall a. Monoid a => a
mempty
  let readonly' = if Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Params -> Maybe [Char]
pRevision Params
params)
                    -- disable editing of text box if it's a revert
                    then (AttributeValue -> Attribute
Html5.Attr.readonly AttributeValue
"readonly")
                          Attribute -> Attribute -> Attribute
forall a. Semigroup a => a -> a -> a
<> AttributeValue -> Attribute
Html5.Attr.style AttributeValue
"color: gray"
                    else Attribute
forall a. Monoid a => a
mempty
  base' <- getWikiBase
  let editForm = AttributeValue -> Html -> Html
gui ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
page) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
"editform"
                   (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
                   [ Html
sha1Box
                   , Html -> Html
textarea (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
readonly' (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
cols AttributeValue
"80" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"editedText" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
!
                                  AttributeValue -> Attribute
Html5.Attr.id AttributeValue
"editedText" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString [Char]
raw
                   , Html
br
                   , Html -> Html
Html5.label (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
for AttributeValue
"logMsg" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Description of changes:"
                   , Html
br
                   , AttributeValue -> AttributeValue -> Html
textfieldInput AttributeValue
"logMsg"  ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
logMsg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
`orIfNull` Config -> [Char]
defaultSummary Config
cfg) Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
readonly'
                   , AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
"update" AttributeValue
"Save"
                   , [Char] -> Html
preEscapedString [Char]
"&nbsp;"
                   , AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
"cancel" AttributeValue
"Discard"
                   , [Char] -> Html
preEscapedString [Char]
"&nbsp;"
                   , Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"button" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"editButton"
                           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
"previewButton"
                           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"updatePreviewPane();"
                           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.style AttributeValue
"display: none;"
                           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value AttributeValue
"Preview"
                   , Html -> Html
Html5.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.id AttributeValue
"previewpane" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
forall a. Monoid a => a
mempty
                   ]
  let pgScripts' = [[Char]
"preview.js"]
  let pgScripts'' = case Config -> MathMethod
mathMethod Config
cfg of
       MathJax [Char]
url  -> [Char]
url [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
pgScripts'
       MathMethod
_            -> [[Char]]
pgScripts'
  formattedPage defaultPageLayout{
                  pgPageName = page,
                  pgMessages = messages,
                  pgRevision = rev,
                  pgShowPageTools = False,
                  pgShowSiteNav = False,
                  pgMarkupHelp = Just $ markupHelp cfg,
                  pgSelectedTab = EditTab,
                  pgScripts = pgScripts'',
                  pgTitle = ("Editing " ++ page)
                  } editForm

confirmDelete :: Handler
confirmDelete :: Handler
confirmDelete = do
  page <- GititServerPart [Char]
getPage
  fs <- getFileStore
  cfg <- getConfig
  -- determine whether there is a corresponding page, and if not whether there
  -- is a corresponding file
  pageTest <- liftIO $ E.try $ latest fs (pathForPage page $ defaultExtension cfg)
  fileToDelete <- case pageTest of
                       Right [Char]
_        -> [Char] -> GititServerPart [Char]
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> GititServerPart [Char])
-> [Char] -> GititServerPart [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
pathForPage [Char]
page ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Config -> [Char]
defaultExtension Config
cfg -- a page
                       Left  FileStoreError
NotFound -> do
                         fileTest <- IO (Either FileStoreError [Char])
-> ServerPartT
     (ReaderT WikiState IO) (Either FileStoreError [Char])
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FileStoreError [Char])
 -> ServerPartT
      (ReaderT WikiState IO) (Either FileStoreError [Char]))
-> IO (Either FileStoreError [Char])
-> ServerPartT
     (ReaderT WikiState IO) (Either FileStoreError [Char])
forall a b. (a -> b) -> a -> b
$ IO [Char] -> IO (Either FileStoreError [Char])
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO [Char] -> IO (Either FileStoreError [Char]))
-> IO [Char] -> IO (Either FileStoreError [Char])
forall a b. (a -> b) -> a -> b
$ FileStore -> [Char] -> IO [Char]
latest FileStore
fs [Char]
page
                         case fileTest of
                              Right [Char]
_       -> [Char] -> GititServerPart [Char]
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
page  -- a source file
                              Left FileStoreError
NotFound -> [Char] -> GititServerPart [Char]
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
                              Left FileStoreError
e        -> [Char] -> GititServerPart [Char]
forall a. [Char] -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (FileStoreError -> [Char]
forall a. Show a => a -> [Char]
show FileStoreError
e)
                       Left FileStoreError
e        -> [Char] -> GititServerPart [Char]
forall a. [Char] -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (FileStoreError -> [Char]
forall a. Show a => a -> [Char]
show FileStoreError
e)
  let confirmForm = AttributeValue -> Html -> Html
gui AttributeValue
"" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
        [ Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Are you sure you want to delete this page?"
        , Html
input Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"text" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"filetodelete"
                Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Html5.Attr.style AttributeValue
"display: none;" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
value ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
fileToDelete)
        , AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
"confirm" AttributeValue
"Yes, delete it!"
        , Html
" "
        , AttributeValue -> AttributeValue -> Html
submitInput AttributeValue
"cancel" AttributeValue
"No, keep it!"
        , Html
br ]
  formattedPage defaultPageLayout{ pgTitle = "Delete " ++ page ++ "?" } $
    if null fileToDelete
       then ul ! class_ "messages" $ li $
            "There is no file or page by that name."
       else confirmForm

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

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

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

fileListToHtml :: String -> String -> String -> [Resource] -> Html
fileListToHtml :: [Char] -> [Char] -> [Char] -> [Resource] -> Html
fileListToHtml [Char]
base' [Char]
prefix [Char]
ext [Resource]
files =
  let fileLink :: Resource -> Html
fileLink (FSFile [Char]
f) | [Char] -> [Char]
takeExtension [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ext =
        Html -> Html
li (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"page" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage ([Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
dropExtension [Char]
f)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
            [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
dropExtension [Char]
f
      fileLink (FSFile [Char]
f) = Html -> Html
li (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"upload" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
        [ Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage ([Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString [Char]
f
        , Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_delete" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage ([Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"(delete)"
        ]
      fileLink (FSDirectory [Char]
f) =
        Html -> Html
li (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"folder" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage ([Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> Html
forall a. IsString a => [Char] -> a
fromString [Char]
f
      updirs :: [[[Char]]]
updirs = Int -> [[[Char]]] -> [[[Char]]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[[Char]]] -> [[[Char]]]) -> [[[Char]]] -> [[[Char]]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[[Char]]]
forall a. [a] -> [[a]]
inits ([[Char]] -> [[[Char]]]) -> [[Char]] -> [[[Char]]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
splitPath ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Char
'/' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
prefix
      uplink :: Html
uplink = ([[Char]] -> Html -> Html) -> Html -> [[[Char]]] -> Html
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[[Char]]
d Html
accum ->
                  [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat [ Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"updir" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
!
                                         AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ if [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
                                                   then [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_index"
                                                   else [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                                        [Char] -> [Char]
urlForPage ([[Char]] -> [Char]
joinPath ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
d)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                  [Char] -> Html
forall a. IsString a => [Char] -> a
fromString ([Char] -> Html) -> [Char] -> Html
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. HasCallStack => [Char] -> [a] -> a
lastNote [Char]
"fileListToHtml" [[Char]]
d, Html
accum]) Html
forall a. Monoid a => a
mempty [[[Char]]]
updirs
  in Html
uplink Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"index" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ (Resource -> Html) -> [Resource] -> Html
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Resource -> Html
fileLink [Resource]
files)

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

categoryListPage :: Handler
categoryListPage :: Handler
categoryListPage = do
  cfg <- GititServerPart Config
getConfig
  let repoPath = Config -> [Char]
repositoryPath Config
cfg
  fs <- getFileStore
  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile
  categories <- liftIO $ liftM (nub . sort . concat) $ forM pages $ \[Char]
f ->
                  [Char] -> IO [[Char]]
readCategories ([Char]
repoPath [Char] -> [Char] -> [Char]
</> [Char]
f)
  base' <- getWikiBase
  let toCatLink [Char]
ctg = Html -> Html
li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/_category" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlForPage [Char]
ctg) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ([Char] -> Html
forall a. IsString a => [Char] -> a
fromString [Char]
ctg)
  let htmlMatches = Html -> Html
ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ([Char] -> Html) -> [[Char]] -> Html
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Char] -> Html
toCatLink [[Char]]
categories
  formattedPage defaultPageLayout{
                  pgPageName = "Categories",
                  pgShowPageTools = False,
                  pgTabs = [],
                  pgScripts = ["search.js"],
                  pgTitle = "Categories" } htmlMatches

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

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