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

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

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

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

{- Handlers for wiki functions.
-}

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

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

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

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

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

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

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

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

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

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

showPageHistory :: Handler
showPageHistory :: Handler
showPageHistory = (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
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  String -> String -> Params -> Handler
showHistory (String -> String -> String
pathForPage String
page (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg) String
page Params
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
  String
file <- GititServerPart String
getPage
  String -> String -> Params -> Handler
showHistory String
file String
file Params
params

showHistory :: String -> String -> Params -> Handler
showHistory :: String -> String -> Params -> Handler
showHistory String
file String
page Params
params =  do
  FileStore
fs <- GititServerPart FileStore
getFileStore
  [Revision]
hist <- IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision])
-> IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall a b. (a -> b) -> a -> b
$ FileStore -> [String] -> TimeRange -> Maybe Int -> IO [Revision]
history FileStore
fs [String
file] (Maybe UTCTime -> Maybe UTCTime -> TimeRange
TimeRange Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing)
            (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Params -> Int
pLimit Params
params)
  String
base' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let versionToHtml :: Revision -> Int -> Html
versionToHtml Revision
rev Int
pos = Html -> Html
li (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"difflink", String -> Int -> HtmlAttr
intAttr String
"order" Int
pos,
                                    String -> String -> HtmlAttr
strAttr String
"revision" (Revision -> String
revId Revision
rev),
                                    String -> String -> HtmlAttr
strAttr String
"diffurl" (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
page)] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"date"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ Revision -> UTCTime
revDateTime Revision
rev)
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"author"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_activity?" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            [(String, String)] -> String
urlEncodeVars [(String
"forUser", Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)]] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
              (Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)
        , String -> Html
stringToHtml String
"): "
        , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?revision=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Revision -> String
revId Revision
rev)] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
           Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"subject"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<  Revision -> String
revDescription Revision
rev
        , Html -> Html
noscript (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            ([ String -> Html
stringToHtml String
" [compare with "
             , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?to=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Revision -> String
revId Revision
rev] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                  String
"previous" ] [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             (if Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
                  then [ String -> Html
primHtmlChar String
"nbsp"
                       , String -> Html
primHtmlChar String
"bull"
                       , String -> Html
primHtmlChar String
"nbsp"
                       , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?from=" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                  Revision -> String
revId Revision
rev] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"current"
                       ]
                  else []) [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++
             [String -> Html
stringToHtml String
"]"])
        ]
  let contents :: Html
contents = if [Revision] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Revision]
hist
                    then Html
noHtml
                    else Html -> Html
ulist (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"history"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                           (Revision -> Int -> Html) -> [Revision] -> [Int] -> [Html]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Revision -> Int -> Html
versionToHtml [Revision]
hist
                           [[Revision] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist, ([Revision] -> 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 :: Html
more = if [Revision] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Revision]
hist Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Params -> Int
pLimit Params
params
                then Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_history" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
page
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?limit=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Params -> Int
pLimit Params
params Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100)] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                                 String
"Show more..."
                else Html
noHtml
  let tabs :: [Tab]
tabs = if String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
page  -- source file, not wiki page
                then [Tab
ViewTab,Tab
HistoryTab]
                else PageLayout -> [Tab]
pgTabs PageLayout
defaultPageLayout
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                   pgPageName :: String
pgPageName = String
page,
                   pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params,
                   pgScripts :: [String]
pgScripts = [String
"dragdiff.js"],
                   pgTabs :: [Tab]
pgTabs = [Tab]
tabs,
                   pgSelectedTab :: Tab
pgSelectedTab = Tab
HistoryTab,
                   pgTitle :: String
pgTitle = (String
"Changes to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
page)
                   } (Html -> Handler) -> Html -> Handler
forall a b. (a -> b) -> a -> b
$ Html
contents Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
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
  Config
cfg <- GititServerPart Config
getConfig
  UTCTime
currTime <- IO UTCTime -> ServerPartT (ReaderT WikiState IO) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let defaultDaysAgo :: NominalDiffTime
defaultDaysAgo = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Config -> Int
recentActivityDays Config
cfg)
  let daysAgo :: UTCTime
daysAgo = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
defaultDaysAgo 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 :: Maybe UTCTime
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 :: Maybe String
forUser = Params -> Maybe String
pForUser Params
params
  FileStore
fs <- GititServerPart FileStore
getFileStore
  [Revision]
hist <- IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision])
-> IO [Revision] -> ServerPartT (ReaderT WikiState IO) [Revision]
forall a b. (a -> b) -> a -> b
$ FileStore -> [String] -> TimeRange -> Maybe Int -> IO [Revision]
history FileStore
fs [] (Maybe UTCTime -> Maybe UTCTime -> TimeRange
TimeRange Maybe UTCTime
since Maybe UTCTime
forall a. Maybe a
Nothing)
                     (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Params -> Int
pLimit Params
params)
  let hist' :: [Revision]
hist' = case Maybe String
forUser of
                   Maybe String
Nothing -> [Revision]
hist
                   Just String
u  -> (Revision -> Bool) -> [Revision] -> [Revision]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Revision
r -> Author -> String
authorName (Revision -> Author
revAuthor Revision
r) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
u) [Revision]
hist
  let fileFromChange :: Change -> String
fileFromChange (Added String
f)    = String
f
      fileFromChange (Modified String
f) = String
f
      fileFromChange (Deleted String
f)  = String
f
  String
base' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let fileAnchor :: String -> String -> Html
fileAnchor String
revis String
file = if String -> String
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Config -> String
defaultExtension Config
cfg)
        then Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_diff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage (String -> String
dropExtension String
file) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?to=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
revis] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> String
dropExtension String
file
        else Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?revision=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
revis] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
file
  let filesFor :: [Change] -> String -> [Html]
filesFor [Change]
changes String
revis = Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse (String -> Html
stringToHtml String
" ") ([Html] -> [Html]) -> [Html] -> [Html]
forall a b. (a -> b) -> a -> b
$
        (Change -> Html) -> [Change] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Html
fileAnchor String
revis (String -> Html) -> (Change -> String) -> Change -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Change -> String
fileFromChange) [Change]
changes
  let heading :: Html
heading = Html -> Html
h1 (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Recent changes by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"all users" Maybe String
forUser)
  let revToListItem :: Revision -> Html
revToListItem Revision
rev = Html -> Html
li (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
        [ Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"date"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ Revision -> UTCTime
revDateTime Revision
rev)
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"author"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/_activity?" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              [(String, String)] -> String
urlEncodeVars [(String
"forUser", Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)]] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                (Author -> String
authorName (Author -> String) -> Author -> String
forall a b. (a -> b) -> a -> b
$ Revision -> Author
revAuthor Revision
rev)
        , String -> Html
stringToHtml String
"): "
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"subject"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Revision -> String
revDescription Revision
rev
        , String -> Html
stringToHtml String
" ("
        , Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"files"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Change] -> String -> [Html]
filesFor (Revision -> [Change]
revChanges Revision
rev) (Revision -> String
revId Revision
rev)
        , String -> Html
stringToHtml String
")"
        ]
  let contents :: Html
contents = Html -> Html
ulist (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"history"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (Revision -> Html) -> [Revision] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Revision -> Html
revToListItem [Revision]
hist'
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params,
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgTabs :: [Tab]
pgTabs = [],
                  pgTitle :: String
pgTitle = String
"Recent changes"
                  } (Html
heading Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
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
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  String -> String -> Params -> Handler
showDiff (String -> String -> String
pathForPage String
page (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Config -> String
defaultExtension Config
cfg) String
page Params
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
  String
page <- GititServerPart String
getPage
  String -> String -> Params -> Handler
showDiff String
page String
page Params
params

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

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

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

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

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

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

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

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

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

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

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

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