{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
Anton van Straaten <anton@appsolutions.com>

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
-}

{- Functions for content conversion.
-}

module Network.Gitit.ContentTransformer
  (
  -- * ContentTransformer runners
    runPageTransformer
  , runFileTransformer
  -- * Gitit responders
  , showRawPage
  , showFileAsText
  , showPage
  , showHighlightedSource
  , showFile
  , preview
  , applyPreCommitPlugins
  -- * Cache support for transformers
  , cacheHtml
  , cachedHtml
  -- * Content retrieval combinators
  , rawContents
  -- * Response-generating combinators
  , textResponse
  , mimeFileResponse
  , mimeResponse
  , applyWikiTemplate
  -- * Content-type transformation combinators
  , pageToWikiPandoc
  , pageToPandoc
  , pandocToHtml
  , highlightSource
  -- * Content or context augmentation combinators
  , applyPageTransforms
  , wikiDivify
  , addPageTitleToPandoc
  , addMathSupport
  , addScripts
  -- * ContentTransformer context API
  , getFileName
  , getPageName
  , getLayout
  , getParams
  , getCacheable
  -- * Pandoc and wiki content conversion support
  , inlinesToURL
  , inlinesToString
  )
where

import qualified Control.Exception as E
import Control.Monad.State
import Control.Monad.Reader (ask)
import Control.Monad.Except (throwError)
import Data.Foldable (traverse_)
import Data.List (stripPrefix)
import Data.Maybe (isNothing, mapMaybe)
import Data.Semigroup ((<>))
import Network.Gitit.Cache (lookupCache, cacheContents)
import Network.Gitit.Framework hiding (uriPath)
import Network.Gitit.Layout
import Network.Gitit.Page (stringToPage)
import Network.Gitit.Server
import Network.Gitit.State
import Network.Gitit.Types
import Network.Gitit.Util (getPageTypeDefaultExtensions)
import Network.HTTP (urlDecode)
import Network.URI (isUnescapedInURI)
import Network.URL (encString)
import System.FilePath
import qualified Text.Pandoc.Builder as B
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Skylighting hiding (Context)
import Text.Pandoc hiding (MathML, WebTeX, MathJax)
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import Text.XHtml.Strict (stringToHtmlString)
#if MIN_VERSION_blaze_html(0,5,0)
import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml )
#else
import Text.Blaze.Renderer.String as Blaze ( renderHtml )
#endif
import URI.ByteString (Query(Query), URIRef(uriPath), laxURIParserOptions,
                       parseURI, uriQuery)
import qualified Data.Text as T
import qualified Data.ByteString as S (concat)
import qualified Data.ByteString.Char8 as SC (pack, unpack)
import qualified Data.ByteString.Lazy as L (toChunks, fromChunks)
import qualified Data.FileStore as FS
import qualified Text.Pandoc as Pandoc

--
-- ContentTransformer runners
--

runPageTransformer :: ToMessage a
               => ContentTransformer a
               -> GititServerPart a
runPageTransformer :: ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer a
xform = (Params -> GititServerPart a) -> GititServerPart a
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> GititServerPart a) -> GititServerPart a)
-> (Params -> GititServerPart a) -> GititServerPart a
forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  ContentTransformer a -> Context -> GititServerPart a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ContentTransformer a
xform  Context :: String
-> PageLayout
-> Bool
-> Bool
-> Bool
-> [String]
-> [(String, String)]
-> Context
Context{ ctxFile :: String
ctxFile = String -> String -> String
pathForPage String
page (Config -> String
defaultExtension Config
cfg)
                           , ctxLayout :: PageLayout
ctxLayout = PageLayout
defaultPageLayout{
                                             pgPageName :: String
pgPageName = String
page
                                           , pgTitle :: String
pgTitle = String
page
                                           , pgPrintable :: Bool
pgPrintable = Params -> Bool
pPrintable Params
params
                                           , pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params
                                           , pgRevision :: Maybe String
pgRevision = Params -> Maybe String
pRevision Params
params
                                           , pgLinkToFeed :: Bool
pgLinkToFeed = Config -> Bool
useFeed Config
cfg }
                           , ctxCacheable :: Bool
ctxCacheable = Bool
True
                           , ctxTOC :: Bool
ctxTOC = Config -> Bool
tableOfContents Config
cfg
                           , ctxBirdTracks :: Bool
ctxBirdTracks = Config -> Bool
showLHSBirdTracks Config
cfg
                           , ctxCategories :: [String]
ctxCategories = []
                           , ctxMeta :: [(String, String)]
ctxMeta = [] }

runFileTransformer :: ToMessage a
               => ContentTransformer a
               -> GititServerPart a
runFileTransformer :: ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer a
xform = (Params -> GititServerPart a) -> GititServerPart a
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> GititServerPart a) -> GititServerPart a)
-> (Params -> GititServerPart a) -> GititServerPart a
forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  ContentTransformer a -> Context -> GititServerPart a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ContentTransformer a
xform  Context :: String
-> PageLayout
-> Bool
-> Bool
-> Bool
-> [String]
-> [(String, String)]
-> Context
Context{ ctxFile :: String
ctxFile = String -> String
forall a. a -> a
id String
page
                           , ctxLayout :: PageLayout
ctxLayout = PageLayout
defaultPageLayout{
                                             pgPageName :: String
pgPageName = String
page
                                           , pgTitle :: String
pgTitle = String
page
                                           , pgPrintable :: Bool
pgPrintable = Params -> Bool
pPrintable Params
params
                                           , pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params
                                           , pgRevision :: Maybe String
pgRevision = Params -> Maybe String
pRevision Params
params
                                           , pgLinkToFeed :: Bool
pgLinkToFeed = Config -> Bool
useFeed Config
cfg }
                           , ctxCacheable :: Bool
ctxCacheable = Bool
True
                           , ctxTOC :: Bool
ctxTOC = Config -> Bool
tableOfContents Config
cfg
                           , ctxBirdTracks :: Bool
ctxBirdTracks = Config -> Bool
showLHSBirdTracks Config
cfg
                           , ctxCategories :: [String]
ctxCategories = []
                           , ctxMeta :: [(String, String)]
ctxMeta = [] }

-- | Converts a @ContentTransformer@ into a @GititServerPart@;
-- specialized to wiki pages.
-- runPageTransformer :: ToMessage a
--                    => ContentTransformer a
--                    -> GititServerPart a
-- runPageTransformer = runTransformer pathForPage

-- | Converts a @ContentTransformer@ into a @GititServerPart@;
-- specialized to non-pages.
-- runFileTransformer :: ToMessage a
--                    => ContentTransformer a
--                    -> GititServerPart a
-- runFileTransformer = runTransformer id

--
-- Gitit responders
--

-- | Responds with raw page source.
showRawPage :: Handler
showRawPage :: Handler
showRawPage = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer Response
rawTextResponse

-- | Responds with raw source (for non-pages such as source
-- code files).
showFileAsText :: Handler
showFileAsText :: Handler
showFileAsText = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer Response
rawTextResponse

-- | Responds with rendered wiki page.
showPage :: Handler
showPage :: Handler
showPage = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer Response
htmlViaPandoc

-- | Responds with highlighted source code.
showHighlightedSource :: Handler
showHighlightedSource :: Handler
showHighlightedSource = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer Response
highlightRawSource

-- | Responds with non-highlighted source code.
showFile :: Handler
showFile :: Handler
showFile = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer (ContentTransformer (Maybe String)
rawContents ContentTransformer (Maybe String)
-> (Maybe String -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> ContentTransformer Response
mimeFileResponse)

-- | Responds with rendered page derived from form data.
preview :: Handler
preview :: Handler
preview = ContentTransformer Response -> Handler
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer (ContentTransformer Response -> Handler)
-> ContentTransformer Response -> Handler
forall a b. (a -> b) -> a -> b
$
          (Params -> String)
-> StateT Context GititServerPart Params
-> StateT Context GititServerPart String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (String -> String) -> (Params -> String) -> Params -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> String
pRaw) StateT Context GititServerPart Params
getParams StateT Context GititServerPart String
-> (String -> StateT Context GititServerPart Page)
-> StateT Context GititServerPart Page
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          String -> StateT Context GititServerPart Page
contentsToPage StateT Context GititServerPart Page
-> (Page -> StateT Context GititServerPart Pandoc)
-> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc StateT Context GititServerPart Pandoc
-> (Pandoc -> StateT Context GititServerPart Html)
-> StateT Context GititServerPart Html
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          Pandoc -> StateT Context GititServerPart Html
pandocToHtml StateT Context GititServerPart Html
-> (Html -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          Response -> ContentTransformer Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> ContentTransformer Response)
-> (Html -> Response) -> Html -> ContentTransformer Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> Response) -> (Html -> String) -> Html -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
forall html. HTML html => html -> String
renderHtmlFragment

-- | Applies pre-commit plugins to raw page source, possibly
-- modifying it.
applyPreCommitPlugins :: String -> GititServerPart String
applyPreCommitPlugins :: String -> GititServerPart String
applyPreCommitPlugins = StateT Context GititServerPart String -> GititServerPart String
forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer (StateT Context GititServerPart String -> GititServerPart String)
-> (String -> StateT Context GititServerPart String)
-> String
-> GititServerPart String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT Context GititServerPart String
applyPreCommitTransforms

--
-- Top level, composed transformers
--

-- | Responds with raw source.
rawTextResponse :: ContentTransformer Response
rawTextResponse :: ContentTransformer Response
rawTextResponse = ContentTransformer (Maybe String)
rawContents ContentTransformer (Maybe String)
-> (Maybe String -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> ContentTransformer Response
textResponse

-- | Responds with a wiki page. Uses the cache when
-- possible and caches the rendered page when appropriate.
htmlViaPandoc :: ContentTransformer Response
htmlViaPandoc :: ContentTransformer Response
htmlViaPandoc = ContentTransformer Response
cachedHtml ContentTransformer Response
-> ContentTransformer Response -> ContentTransformer Response
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  (ContentTransformer (Maybe String)
rawContents ContentTransformer (Maybe String)
-> (Maybe String -> StateT Context GititServerPart String)
-> StateT Context GititServerPart String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   StateT Context GititServerPart String
-> (String -> StateT Context GititServerPart String)
-> Maybe String
-> StateT Context GititServerPart String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT Context GititServerPart String
forall (m :: * -> *) a. MonadPlus m => m a
mzero String -> StateT Context GititServerPart String
forall (m :: * -> *) a. Monad m => a -> m a
return StateT Context GititServerPart String
-> (String -> StateT Context GititServerPart Page)
-> StateT Context GititServerPart Page
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   String -> StateT Context GititServerPart Page
contentsToPage StateT Context GititServerPart Page
-> (Page -> StateT Context GititServerPart (Either Response Page))
-> StateT Context GititServerPart (Either Response Page)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   Page -> StateT Context GititServerPart (Either Response Page)
handleRedirects StateT Context GititServerPart (Either Response Page)
-> (Either Response Page -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   (Response -> ContentTransformer Response)
-> (Page -> ContentTransformer Response)
-> Either Response Page
-> ContentTransformer Response
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Response -> ContentTransformer Response
forall (m :: * -> *) a. Monad m => a -> m a
return
                     (Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc (Page -> StateT Context GititServerPart Pandoc)
-> (Pandoc -> ContentTransformer Response)
-> Page
-> ContentTransformer Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Pandoc -> StateT Context GititServerPart Pandoc
forall a. a -> ContentTransformer a
addMathSupport (Pandoc -> StateT Context GititServerPart Pandoc)
-> (Pandoc -> ContentTransformer Response)
-> Pandoc
-> ContentTransformer Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Pandoc -> StateT Context GititServerPart Html
pandocToHtml (Pandoc -> StateT Context GititServerPart Html)
-> (Html -> ContentTransformer Response)
-> Pandoc
-> ContentTransformer Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Html -> StateT Context GititServerPart Html
wikiDivify (Html -> StateT Context GititServerPart Html)
-> (Html -> ContentTransformer Response)
-> Html
-> ContentTransformer Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Html -> ContentTransformer Response
applyWikiTemplate (Html -> ContentTransformer Response)
-> (Response -> ContentTransformer Response)
-> Html
-> ContentTransformer Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Response -> ContentTransformer Response
cacheHtml))

-- | Responds with highlighted source code in a wiki
-- page template.  Uses the cache when possible and
-- caches the rendered page when appropriate.
highlightRawSource :: ContentTransformer Response
highlightRawSource :: ContentTransformer Response
highlightRawSource =
  ContentTransformer Response
cachedHtml ContentTransformer Response
-> ContentTransformer Response -> ContentTransformer Response
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    ((PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout (\PageLayout
l -> PageLayout
l { pgTabs :: [Tab]
pgTabs = [Tab
ViewTab,Tab
HistoryTab] }) ContentTransformer ()
-> ContentTransformer (Maybe String)
-> ContentTransformer (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
     ContentTransformer (Maybe String)
rawContents ContentTransformer (Maybe String)
-> (Maybe String -> StateT Context GititServerPart Html)
-> StateT Context GititServerPart Html
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Maybe String -> StateT Context GititServerPart Html
highlightSource StateT Context GititServerPart Html
-> (Html -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Html -> ContentTransformer Response
applyWikiTemplate ContentTransformer Response
-> (Response -> ContentTransformer Response)
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Response -> ContentTransformer Response
cacheHtml)

--
-- Cache support for transformers
--

-- | Caches a response (actually just the response body) on disk,
-- unless the context indicates that the page is not cacheable.
cacheHtml :: Response -> ContentTransformer Response
cacheHtml :: Response -> ContentTransformer Response
cacheHtml Response
resp' = do
  Params
params <- StateT Context GititServerPart Params
getParams
  String
file <- StateT Context GititServerPart String
getFileName
  Bool
cacheable <- ContentTransformer Bool
getCacheable
  Config
cfg <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  Bool -> ContentTransformer () -> ContentTransformer ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
useCache Config
cfg Bool -> Bool -> Bool
&& Bool
cacheable Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Params -> Maybe String
pRevision Params
params) Bool -> Bool -> Bool
&& Bool -> Bool
not (Params -> Bool
pPrintable Params
params)) (ContentTransformer () -> ContentTransformer ())
-> ContentTransformer () -> ContentTransformer ()
forall a b. (a -> b) -> a -> b
$
    ServerPartT (ReaderT WikiState IO) () -> ContentTransformer ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPartT (ReaderT WikiState IO) () -> ContentTransformer ())
-> ServerPartT (ReaderT WikiState IO) () -> ContentTransformer ()
forall a b. (a -> b) -> a -> b
$ 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]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rsBody Response
resp'
  Response -> ContentTransformer Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
resp'

-- | Returns cached page if available, otherwise mzero.
cachedHtml :: ContentTransformer Response
cachedHtml :: ContentTransformer Response
cachedHtml = do
  String
file <- StateT Context GititServerPart String
getFileName
  Params
params <- StateT Context GititServerPart Params
getParams
  Config
cfg <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  if Config -> Bool
useCache Config
cfg Bool -> Bool -> Bool
&& Bool -> Bool
not (Params -> Bool
pPrintable Params
params) Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Params -> Maybe String
pRevision Params
params)
     then do Maybe (UTCTime, ByteString)
mbCached <- ServerPartT (ReaderT WikiState IO) (Maybe (UTCTime, ByteString))
-> StateT Context GititServerPart (Maybe (UTCTime, ByteString))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPartT (ReaderT WikiState IO) (Maybe (UTCTime, ByteString))
 -> StateT Context GititServerPart (Maybe (UTCTime, ByteString)))
-> ServerPartT (ReaderT WikiState IO) (Maybe (UTCTime, ByteString))
-> StateT Context GititServerPart (Maybe (UTCTime, ByteString))
forall a b. (a -> b) -> a -> b
$ String
-> ServerPartT (ReaderT WikiState IO) (Maybe (UTCTime, ByteString))
lookupCache String
file
             let emptyResponse :: Response
emptyResponse = String -> Response -> Response
setContentType String
"text/html; 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
$ ()
             ContentTransformer Response
-> ((UTCTime, ByteString) -> ContentTransformer Response)
-> Maybe (UTCTime, ByteString)
-> ContentTransformer Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContentTransformer Response
forall (m :: * -> *) a. MonadPlus m => m a
mzero (\(UTCTime
_modtime, ByteString
contents) -> Handler -> ContentTransformer Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler -> ContentTransformer Response)
-> (Response -> Handler) -> Response -> ContentTransformer Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ContentTransformer Response)
-> Response -> ContentTransformer Response
forall a b. (a -> b) -> a -> b
$ Response
emptyResponse{rsBody :: ByteString
rsBody = [ByteString] -> ByteString
L.fromChunks [ByteString
contents]}) Maybe (UTCTime, ByteString)
mbCached
     else ContentTransformer Response
forall (m :: * -> *) a. MonadPlus m => m a
mzero

--
-- Content retrieval combinators
--

-- | Returns raw file contents.
rawContents :: ContentTransformer (Maybe String)
rawContents :: ContentTransformer (Maybe String)
rawContents = do
  Params
params <- StateT Context GititServerPart Params
getParams
  String
file <- StateT Context GititServerPart String
getFileName
  FileStore
fs <- ServerPartT (ReaderT WikiState IO) FileStore
-> StateT Context GititServerPart FileStore
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ServerPartT (ReaderT WikiState IO) FileStore
getFileStore
  let rev :: Maybe String
rev = Params -> Maybe String
pRevision Params
params
  IO (Maybe String) -> ContentTransformer (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> ContentTransformer (Maybe String))
-> IO (Maybe String) -> ContentTransformer (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO (Maybe String)
-> (FileStoreError -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch ((String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ FileStore -> String -> Maybe String -> IO String
FileStore -> forall a. Contents a => String -> Maybe String -> IO a
FS.retrieve FileStore
fs String
file Maybe String
rev)
               (\FileStoreError
e -> if FileStoreError
e FileStoreError -> FileStoreError -> Bool
forall a. Eq a => a -> a -> Bool
== FileStoreError
FS.NotFound then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else FileStoreError -> IO (Maybe String)
forall e a. Exception e => e -> IO a
E.throwIO FileStoreError
e)

--
-- Response-generating combinators
--

-- | Converts raw contents to a text/plain response.
textResponse :: Maybe String -> ContentTransformer Response
textResponse :: Maybe String -> ContentTransformer Response
textResponse Maybe String
Nothing  = ContentTransformer Response
forall (m :: * -> *) a. MonadPlus m => m a
mzero  -- fail quietly if file not found
textResponse (Just String
c) = String -> String -> ContentTransformer Response
forall (m :: * -> *). Monad m => String -> String -> m Response
mimeResponse String
c String
"text/plain; charset=utf-8"

-- | Converts raw contents to a response that is appropriate with
-- a mime type derived from the page's extension.
mimeFileResponse :: Maybe String -> ContentTransformer Response
mimeFileResponse :: Maybe String -> ContentTransformer Response
mimeFileResponse Maybe String
Nothing = String -> ContentTransformer Response
forall a. HasCallStack => String -> a
error String
"Unable to retrieve file contents."
mimeFileResponse (Just String
c) =
  String -> String -> ContentTransformer Response
forall (m :: * -> *). Monad m => String -> String -> m Response
mimeResponse String
c (String -> ContentTransformer Response)
-> StateT Context GititServerPart String
-> ContentTransformer Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GititServerPart String -> StateT Context GititServerPart String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GititServerPart String -> StateT Context GititServerPart String)
-> (String -> GititServerPart String)
-> String
-> StateT Context GititServerPart String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GititServerPart String
getMimeTypeForExtension (String -> GititServerPart String)
-> (String -> String) -> String -> GititServerPart String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension (String -> StateT Context GititServerPart String)
-> StateT Context GititServerPart String
-> StateT Context GititServerPart String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT Context GititServerPart String
getFileName

mimeResponse :: Monad m
             => String        -- ^ Raw contents for response body
             -> String        -- ^ Mime type
             -> m Response
mimeResponse :: String -> String -> m Response
mimeResponse String
c String
mimeType =
  Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response)
-> (String -> Response) -> String -> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Response -> Response
setContentType String
mimeType (Response -> Response)
-> (String -> Response) -> String -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> m Response) -> String -> m Response
forall a b. (a -> b) -> a -> b
$ String
c

-- | Adds the sidebar, page tabs, and other elements of the wiki page
-- layout to the raw content.
applyWikiTemplate :: Html -> ContentTransformer Response
applyWikiTemplate :: Html -> ContentTransformer Response
applyWikiTemplate Html
c = do
  Context { ctxLayout :: Context -> PageLayout
ctxLayout = PageLayout
layout } <- StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  Handler -> ContentTransformer Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler -> ContentTransformer Response)
-> Handler -> ContentTransformer Response
forall a b. (a -> b) -> a -> b
$ PageLayout -> Html -> Handler
formattedPage PageLayout
layout Html
c

--
-- Content-type transformation combinators
--

-- | Converts Page to Pandoc, applies page transforms, and adds page
-- title.
pageToWikiPandoc :: Page -> ContentTransformer Pandoc
pageToWikiPandoc :: Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc Page
page' =
  Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc' Page
page' StateT Context GititServerPart Pandoc
-> (Pandoc -> StateT Context GititServerPart Pandoc)
-> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Pandoc -> StateT Context GititServerPart Pandoc
addPageTitleToPandoc (Page -> String
pageTitle Page
page')

pageToWikiPandoc' :: Page -> ContentTransformer Pandoc
pageToWikiPandoc' :: Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc' = Page -> StateT Context GititServerPart Page
applyPreParseTransforms (Page -> StateT Context GititServerPart Page)
-> (Page -> StateT Context GititServerPart Pandoc)
-> Page
-> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                     Page -> StateT Context GititServerPart Pandoc
pageToPandoc (Page -> StateT Context GititServerPart Pandoc)
-> (Pandoc -> StateT Context GititServerPart Pandoc)
-> Page
-> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Pandoc -> StateT Context GititServerPart Pandoc
applyPageTransforms

-- | Converts source text to Pandoc using default page type.
pageToPandoc :: Page -> ContentTransformer Pandoc
pageToPandoc :: Page -> StateT Context GititServerPart Pandoc
pageToPandoc Page
page' = do
  (Context -> Context) -> ContentTransformer ()
forall (m :: * -> *). HasContext m => (Context -> Context) -> m ()
modifyContext ((Context -> Context) -> ContentTransformer ())
-> (Context -> Context) -> ContentTransformer ()
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> Context
ctx{ ctxTOC :: Bool
ctxTOC = Page -> Bool
pageTOC Page
page'
                             , ctxCategories :: [String]
ctxCategories = Page -> [String]
pageCategories Page
page'
                             , ctxMeta :: [(String, String)]
ctxMeta = Page -> [(String, String)]
pageMeta Page
page' }
  (PandocError -> StateT Context GititServerPart Pandoc)
-> (Pandoc -> StateT Context GititServerPart Pandoc)
-> Either PandocError Pandoc
-> StateT Context GititServerPart Pandoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO Pandoc -> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Pandoc -> StateT Context GititServerPart Pandoc)
-> (PandocError -> IO Pandoc)
-> PandocError
-> StateT Context GititServerPart Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocError -> IO Pandoc
forall e a. Exception e => e -> IO a
E.throwIO) Pandoc -> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PandocError Pandoc
 -> StateT Context GititServerPart Pandoc)
-> Either PandocError Pandoc
-> StateT Context GititServerPart Pandoc
forall a b. (a -> b) -> a -> b
$ PageType -> Bool -> String -> Either PandocError Pandoc
readerFor (Page -> PageType
pageFormat Page
page') (Page -> Bool
pageLHS Page
page') (Page -> String
pageText Page
page')

-- | Detects if the page is a redirect page and handles accordingly. The exact
-- behaviour is as follows:
--
-- If the page is /not/ a redirect page (the most common case), then check the
-- referer to see if the client came to this page as a result of a redirect
-- from another page. If so, then add a notice to the messages to notify the
-- user that they were redirected from another page, and provide a link back
-- to the original page, with an extra parameter to disable redirection
-- (e.g., to allow the original page to be edited).
--
-- If the page /is/ a redirect page, then check the query string for the
-- @redirect@ parameter. This can modify the behaviour of the redirect as
-- follows:
--
-- 1. If the @redirect@ parameter is unset, then check the referer to see if
--    client came to this page as a result of a redirect from another page. If
--    so, then do not redirect, and add a notice to the messages explaining
--    that this page is a redirect page, that would have redirected to the
--    destination given in the metadata (and provide a link thereto), but this
--    was stopped because a double-redirect was detected. This is a simple way
--    to prevent cyclical redirects and other abuses enabled by redirects.
--    redirect to the same page. If the client did /not/ come to this page as
--    a result of a redirect, then redirect back to the same page, except with
--    the redirect parameter set to @\"yes\"@.
--
-- 2. If the @redirect@ parameter is set to \"yes\", then redirect to the
--    destination specificed in the metadata. This uses a client-side (meta
--    refresh + javascript backup) redirect to make sure the referer is set to
--    this URL.
--
-- 3. If the @redirect@ parameter is set to \"no\", then do not redirect, but
--    add a notice to the messages that this page /would/ have redirected to
--    the destination given in the metadata had it not been disabled, and
--    provide a link to the destination given in the metadata. This behaviour
--    is the @revision@ parameter is present in the query string.
handleRedirects :: Page -> ContentTransformer (Either Response Page)
handleRedirects :: Page -> StateT Context GititServerPart (Either Response Page)
handleRedirects Page
page = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"redirect" (Page -> [(String, String)]
pageMeta Page
page) of
    Maybe String
Nothing -> StateT Context GititServerPart (Either Response Page)
forall a. StateT Context GititServerPart (Either a Page)
isn'tRedirect
    Just String
destination -> String -> StateT Context GititServerPart (Either Response Page)
isRedirect String
destination
  where
    addMessage :: String -> m ()
addMessage String
message = (Context -> Context) -> m ()
forall (m :: * -> *). HasContext m => (Context -> Context) -> m ()
modifyContext ((Context -> Context) -> m ()) -> (Context -> Context) -> m ()
forall a b. (a -> b) -> a -> b
$ \Context
context -> Context
context
        { ctxLayout :: PageLayout
ctxLayout = (Context -> PageLayout
ctxLayout Context
context)
            { pgMessages :: [String]
pgMessages = PageLayout -> [String]
pgMessages (Context -> PageLayout
ctxLayout Context
context) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
message]
            }
        }
    redirectedFrom :: String -> m String
redirectedFrom String
source = do
        (String
url, String
html) <- String -> m (String, String)
forall (m :: * -> *). ServerMonad m => String -> m (String, String)
processSource String
source
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Redirected from <a href=\""
            , String
url
            , String
"?redirect=no\" title=\"Go to original page\">"
            , String
html
            , String
"</a>"
            ]
    doubleRedirect :: String -> String -> m String
doubleRedirect String
source String
destination = do
        (String
url, String
html) <- String -> m (String, String)
forall (m :: * -> *). ServerMonad m => String -> m (String, String)
processSource String
source
        (String
url', String
html') <- String -> m (String, String)
forall (m :: * -> *). ServerMonad m => String -> m (String, String)
processDestination String
destination
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"This page normally redirects to <a href=\""
            , String
url'
            , String
"\" title=\"Continue to destination\">"
            , String
html'
            , String
"</a>, but as you were already redirected from <a href=\""
            , String
url
            , String
"?redirect=no\" title=\"Go to original page\">"
            , String
html
            , String
"</a>"
            , String
", this was stopped to prevent a double-redirect."
            ]
    cancelledRedirect :: String -> m String
cancelledRedirect String
destination = do
        (String
url', String
html') <- String -> m (String, String)
forall (m :: * -> *). ServerMonad m => String -> m (String, String)
processDestination String
destination
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"This page redirects to <a href=\""
            , String
url'
            , String
"\" title=\"Continue to destination\">"
            , String
html'
            , String
"</a>."
            ]
    processSource :: String -> m (String, String)
processSource String
source = do
        String
base' <- m String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        let url :: String
url = String -> String
stringToHtmlString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
source
        let html :: String
html = String -> String
stringToHtmlString String
source
        (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
url, String
html)
    processDestination :: String -> m (String, String)
processDestination String
destination = do
        String
base' <- m String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        let (String
page', String
fragment) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') String
destination
        let url :: String
url = String -> String
stringToHtmlString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ String
base'
             , String -> String
urlForPage String
page'
             , String
fragment
             ]
        let html :: String
html = String -> String
stringToHtmlString String
page'
        (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
url, String
html)
    getSource :: ContentTransformer (Maybe String)
getSource = do
        Config
cfg <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
        String
base' <- StateT Context GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        Request
request <- StateT Context GititServerPart Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
        Maybe String -> ContentTransformer (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> ContentTransformer (Maybe String))
-> Maybe String -> ContentTransformer (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            ByteString
referer <- String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"referer" Request
request
            URIRef Absolute
uri <- case URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
laxURIParserOptions ByteString
referer of
                Left URIParseError
_ -> Maybe (URIRef Absolute)
forall a. Maybe a
Nothing
                Right URIRef Absolute
uri -> URIRef Absolute -> Maybe (URIRef Absolute)
forall a. a -> Maybe a
Just URIRef Absolute
uri
            let Query [(ByteString, ByteString)]
params = URIRef Absolute -> Query
uriQuery URIRef Absolute
uri
            ByteString
redirect' <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
SC.pack String
"redirect") [(ByteString, ByteString)]
params
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
redirect' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
SC.pack String
"yes"
            String
path' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String
base' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") (ByteString -> String
SC.unpack (URIRef Absolute -> ByteString
uriPath URIRef Absolute
uri))
            let path'' :: String
path'' = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then Config -> String
frontPage Config
cfg else String -> String
urlDecode String
path'
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
isPage String
path''
            String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path''
    withBody :: String -> Response
withBody = String -> Response -> Response
setContentType String
"text/html; charset=utf-8" (Response -> Response)
-> (String -> Response) -> String -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Response
forall a. ToMessage a => a -> Response
toResponse
    isn'tRedirect :: StateT Context GititServerPart (Either a Page)
isn'tRedirect = do
        ContentTransformer (Maybe String)
getSource ContentTransformer (Maybe String)
-> (Maybe String -> ContentTransformer ()) -> ContentTransformer ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ContentTransformer ())
-> Maybe String -> ContentTransformer ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String -> StateT Context GititServerPart String
forall (m :: * -> *). ServerMonad m => String -> m String
redirectedFrom (String -> StateT Context GititServerPart String)
-> (String -> ContentTransformer ())
-> String
-> ContentTransformer ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> ContentTransformer ()
forall (m :: * -> *). HasContext m => String -> m ()
addMessage)
        Either a Page -> StateT Context GititServerPart (Either a Page)
forall (m :: * -> *) a. Monad m => a -> m a
return (Page -> Either a Page
forall a b. b -> Either a b
Right Page
page)
    isRedirect :: String -> StateT Context GititServerPart (Either Response Page)
isRedirect String
destination = do
        Params
params <- StateT Context GititServerPart Params
getParams
        case Maybe Bool -> (String -> Maybe Bool) -> Maybe String -> Maybe Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Params -> Maybe Bool
pRedirect Params
params) (\String
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (Params -> Maybe String
pRevision Params
params) of
             Maybe Bool
Nothing -> do
                Maybe String
source <- ContentTransformer (Maybe String)
getSource
                case Maybe String
source of
                     Just String
source' -> do
                        String -> String -> StateT Context GititServerPart String
forall (m :: * -> *). ServerMonad m => String -> String -> m String
doubleRedirect String
source' String
destination StateT Context GititServerPart String
-> (String -> ContentTransformer ()) -> ContentTransformer ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ContentTransformer ()
forall (m :: * -> *). HasContext m => String -> m ()
addMessage
                        Either Response Page
-> StateT Context GititServerPart (Either Response Page)
forall (m :: * -> *) a. Monad m => a -> m a
return (Page -> Either Response Page
forall a b. b -> Either a b
Right Page
page)
                     Maybe String
Nothing -> (Response -> Either Response Page)
-> ContentTransformer Response
-> StateT Context GititServerPart (Either Response Page)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Either Response Page
forall a b. a -> Either a b
Left (ContentTransformer Response
 -> StateT Context GititServerPart (Either Response Page))
-> ContentTransformer Response
-> StateT Context GititServerPart (Either Response Page)
forall a b. (a -> b) -> a -> b
$ do
                        String
base' <- StateT Context GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
                        let url' :: String
url' = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                             [ String
base'
                             , String -> String
urlForPage (Page -> String
pageName Page
page)
                             , String
"?redirect=yes"
                             ]
                        Handler -> ContentTransformer Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler -> ContentTransformer Response)
-> Handler -> ContentTransformer Response
forall a b. (a -> b) -> a -> b
$ String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther String
url' (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response
withBody (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [ String
"<!doctype html><html><head><title>307 Redirect"
                            , String
"</title></head><body><p>You are being <a href=\""
                            , String -> String
stringToHtmlString String
url'
                            , String
"\">redirected</a>.</body></p></html>"
                            ]
             Just Bool
True -> (Response -> Either Response Page)
-> ContentTransformer Response
-> StateT Context GititServerPart (Either Response Page)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Either Response Page
forall a b. a -> Either a b
Left (ContentTransformer Response
 -> StateT Context GititServerPart (Either Response Page))
-> ContentTransformer Response
-> StateT Context GititServerPart (Either Response Page)
forall a b. (a -> b) -> a -> b
$ do
                (String
url', String
html') <- String -> StateT Context GititServerPart (String, String)
forall (m :: * -> *). ServerMonad m => String -> m (String, String)
processDestination String
destination
                Handler -> ContentTransformer Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler -> ContentTransformer Response)
-> Handler -> ContentTransformer 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
$ String -> Response
withBody (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"<!doctype html><html><head><title>Redirecting to "
                    , String
html'
                    , String
"</title><meta http-equiv=\"refresh\" contents=\"0; url="
                    , String
url'
                    , String
"\" /><script type=\"text/javascript\">window.location=\""
                    , String
url'
                    , String
"\"</script></head><body><p>Redirecting to <a href=\""
                    , String
url'
                    , String
"\">"
                    , String
html'
                    , String
"</a>...</p></body></html>"
                    ]
             Just Bool
False -> do
                String -> StateT Context GititServerPart String
forall (m :: * -> *). ServerMonad m => String -> m String
cancelledRedirect String
destination StateT Context GititServerPart String
-> (String -> ContentTransformer ()) -> ContentTransformer ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ContentTransformer ()
forall (m :: * -> *). HasContext m => String -> m ()
addMessage
                Either Response Page
-> StateT Context GititServerPart (Either Response Page)
forall (m :: * -> *) a. Monad m => a -> m a
return (Page -> Either Response Page
forall a b. b -> Either a b
Right Page
page)

-- | Converts contents of page file to Page object.
contentsToPage :: String -> ContentTransformer Page
contentsToPage :: String -> StateT Context GititServerPart Page
contentsToPage String
s = do
  Config
cfg <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  String
pn <- StateT Context GititServerPart String
getPageName
  Page -> StateT Context GititServerPart Page
forall (m :: * -> *) a. Monad m => a -> m a
return (Page -> StateT Context GititServerPart Page)
-> Page -> StateT Context GititServerPart Page
forall a b. (a -> b) -> a -> b
$ Config -> String -> String -> Page
stringToPage Config
cfg String
pn String
s

-- | Converts pandoc document to HTML.
pandocToHtml :: Pandoc -> ContentTransformer Html
pandocToHtml :: Pandoc -> StateT Context GititServerPart Html
pandocToHtml Pandoc
pandocContents = do
  Bool
toc <- (Context -> Bool)
-> StateT Context GititServerPart Context
-> ContentTransformer Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxTOC StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  Bool
bird <- (Context -> Bool)
-> StateT Context GititServerPart Context
-> ContentTransformer Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxBirdTracks StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  Config
cfg <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  let tpl :: Text
tpl = Text
"$if(toc)$<div id=\"TOC\">\n$toc$\n</div>\n$endif$\n$body$"
  Template Text
compiledTemplate <- IO (Template Text)
-> StateT Context GititServerPart (Template Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Template Text)
 -> StateT Context GititServerPart (Template Text))
-> IO (Template Text)
-> StateT Context GititServerPart (Template Text)
forall a b. (a -> b) -> a -> b
$ PandocIO (Template Text) -> IO (Template Text)
forall a. PandocIO a -> IO a
runIOorExplode (PandocIO (Template Text) -> IO (Template Text))
-> PandocIO (Template Text) -> IO (Template Text)
forall a b. (a -> b) -> a -> b
$ do
    Either String (Template Text)
res <- WithDefaultPartials PandocIO (Either String (Template Text))
-> PandocIO (Either String (Template Text))
forall (m :: * -> *) a. WithDefaultPartials m a -> m a
runWithDefaultPartials (WithDefaultPartials PandocIO (Either String (Template Text))
 -> PandocIO (Either String (Template Text)))
-> WithDefaultPartials PandocIO (Either String (Template Text))
-> PandocIO (Either String (Template Text))
forall a b. (a -> b) -> a -> b
$ String
-> Text
-> WithDefaultPartials PandocIO (Either String (Template Text))
forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate String
"toc" Text
tpl
    case Either String (Template Text)
res of
      Right Template Text
t -> Template Text -> PandocIO (Template Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Template Text
t
      Left String
e  -> PandocError -> PandocIO (Template Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocIO (Template Text))
-> PandocError -> PandocIO (Template Text)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocTemplateError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e
  Html -> StateT Context GititServerPart Html
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> StateT Context GititServerPart Html)
-> Html -> StateT Context GititServerPart Html
forall a b. (a -> b) -> a -> b
$ String -> Html
primHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (if Config -> Bool
xssSanitize Config
cfg then Text -> Text
sanitizeBalance else Text -> Text
forall a. a -> a
id) (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
           (PandocError -> Text)
-> (Text -> Text) -> Either PandocError Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PandocError -> Text
forall a e. Exception e => e -> a
E.throw Text -> Text
forall a. a -> a
id (Either PandocError Text -> Text)
-> (PandocPure Text -> Either PandocError Text)
-> PandocPure Text
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Text) -> PandocPure Text -> Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
forall a. Default a => a
def{
                        writerTemplate :: Maybe (Template Text)
writerTemplate = Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just Template Text
compiledTemplate
                      , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod =
                            case Config -> MathMethod
mathMethod Config
cfg of
                                 MathMethod
MathML -> HTMLMathMethod
Pandoc.MathML
                                 WebTeX String
u -> Text -> HTMLMathMethod
Pandoc.WebTeX (Text -> HTMLMathMethod) -> Text -> HTMLMathMethod
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
u
                                 MathJax String
u -> Text -> HTMLMathMethod
Pandoc.MathJax (Text -> HTMLMathMethod) -> Text -> HTMLMathMethod
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
u
                                 MathMethod
RawTeX -> HTMLMathMethod
Pandoc.PlainMath
                      , writerTableOfContents :: Bool
writerTableOfContents = Bool
toc
                      , writerHighlightStyle :: Maybe Style
writerHighlightStyle = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
pygments
                      , writerExtensions :: Extensions
writerExtensions = if Bool
bird
                                              then Extension -> Extensions -> Extensions
enableExtension Extension
Ext_literate_haskell
                                                   (Extensions -> Extensions) -> Extensions -> Extensions
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Extensions
writerExtensions WriterOptions
forall a. Default a => a
def
                                              else WriterOptions -> Extensions
writerExtensions WriterOptions
forall a. Default a => a
def
                      -- note: javascript obfuscation gives problems on preview
                      , writerEmailObfuscation :: ObfuscationMethod
writerEmailObfuscation = ObfuscationMethod
ReferenceObfuscation
                      } Pandoc
pandocContents

-- | Returns highlighted source code.
highlightSource :: Maybe String -> ContentTransformer Html
highlightSource :: Maybe String -> StateT Context GititServerPart Html
highlightSource Maybe String
Nothing = StateT Context GititServerPart Html
forall (m :: * -> *) a. MonadPlus m => m a
mzero
highlightSource (Just String
source) = do
  String
file <- StateT Context GititServerPart String
getFileName
  let formatOpts :: FormatOptions
formatOpts = FormatOptions
defaultFormatOpts { numberLines :: Bool
numberLines = Bool
True, lineAnchors :: Bool
lineAnchors = Bool
True }
  case SyntaxMap -> String -> [Syntax]
syntaxesByFilename SyntaxMap
defaultSyntaxMap String
file of
        []    -> StateT Context GititServerPart Html
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        (Syntax
l:[Syntax]
_) -> case TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
tokenize TokenizerConfig :: SyntaxMap -> Bool -> TokenizerConfig
TokenizerConfig{
                              syntaxMap :: SyntaxMap
syntaxMap = SyntaxMap
defaultSyntaxMap
                            , traceOutput :: Bool
traceOutput = Bool
False} Syntax
l
                        (Text -> Either String [SourceLine])
-> Text -> Either String [SourceLine]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\r') String
source of
                    Left String
e ->  String -> StateT Context GititServerPart Html
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String
forall a. Show a => a -> String
show String
e)
                    Right [SourceLine]
r -> Html -> StateT Context GititServerPart Html
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> StateT Context GititServerPart Html)
-> Html -> StateT Context GititServerPart Html
forall a b. (a -> b) -> a -> b
$ String -> Html
primHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Html -> String
Blaze.renderHtml
                                      (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$ FormatOptions -> [SourceLine] -> Html
formatHtmlBlock FormatOptions
formatOpts [SourceLine]
r

--
-- Plugin combinators
--

getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms = ([Plugin] -> [Pandoc -> PluginM Pandoc])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [Pandoc -> PluginM Pandoc]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Plugin -> Maybe (Pandoc -> PluginM Pandoc))
-> [Plugin] -> [Pandoc -> PluginM Pandoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (Pandoc -> PluginM Pandoc)
pageTransform) (StateT Context GititServerPart [Plugin]
 -> ContentTransformer [Pandoc -> PluginM Pandoc])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [Pandoc -> PluginM Pandoc]
forall a b. (a -> b) -> a -> b
$ (GititState -> [Plugin]) -> StateT Context GititServerPart [Plugin]
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where pageTransform :: Plugin -> Maybe (Pandoc -> PluginM Pandoc)
pageTransform (PageTransform Pandoc -> PluginM Pandoc
x) = (Pandoc -> PluginM Pandoc) -> Maybe (Pandoc -> PluginM Pandoc)
forall a. a -> Maybe a
Just Pandoc -> PluginM Pandoc
x
        pageTransform Plugin
_                 = Maybe (Pandoc -> PluginM Pandoc)
forall a. Maybe a
Nothing

getPreParseTransforms :: ContentTransformer [String -> PluginM String]
getPreParseTransforms :: ContentTransformer [String -> PluginM String]
getPreParseTransforms = ([Plugin] -> [String -> PluginM String])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [String -> PluginM String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Plugin -> Maybe (String -> PluginM String))
-> [Plugin] -> [String -> PluginM String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (String -> PluginM String)
preParseTransform) (StateT Context GititServerPart [Plugin]
 -> ContentTransformer [String -> PluginM String])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [String -> PluginM String]
forall a b. (a -> b) -> a -> b
$
                          (GititState -> [Plugin]) -> StateT Context GititServerPart [Plugin]
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where preParseTransform :: Plugin -> Maybe (String -> PluginM String)
preParseTransform (PreParseTransform String -> PluginM String
x) = (String -> PluginM String) -> Maybe (String -> PluginM String)
forall a. a -> Maybe a
Just String -> PluginM String
x
        preParseTransform Plugin
_                     = Maybe (String -> PluginM String)
forall a. Maybe a
Nothing

getPreCommitTransforms :: ContentTransformer [String -> PluginM String]
getPreCommitTransforms :: ContentTransformer [String -> PluginM String]
getPreCommitTransforms = ([Plugin] -> [String -> PluginM String])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [String -> PluginM String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Plugin -> Maybe (String -> PluginM String))
-> [Plugin] -> [String -> PluginM String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (String -> PluginM String)
preCommitTransform) (StateT Context GititServerPart [Plugin]
 -> ContentTransformer [String -> PluginM String])
-> StateT Context GititServerPart [Plugin]
-> ContentTransformer [String -> PluginM String]
forall a b. (a -> b) -> a -> b
$
                          (GititState -> [Plugin]) -> StateT Context GititServerPart [Plugin]
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where preCommitTransform :: Plugin -> Maybe (String -> PluginM String)
preCommitTransform (PreCommitTransform String -> PluginM String
x) = (String -> PluginM String) -> Maybe (String -> PluginM String)
forall a. a -> Maybe a
Just String -> PluginM String
x
        preCommitTransform Plugin
_                      = Maybe (String -> PluginM String)
forall a. Maybe a
Nothing

-- | @applyTransform a t@ applies the transform @t@ to input @a@.
applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a
applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a
applyTransform a
inp a -> PluginM a
transform = do
  Context
context <- StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  Config
conf <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  Maybe User
user <- ServerPartT (ReaderT WikiState IO) (Maybe User)
-> StateT Context GititServerPart (Maybe User)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ServerPartT (ReaderT WikiState IO) (Maybe User)
getLoggedInUser
  FileStore
fs <- ServerPartT (ReaderT WikiState IO) FileStore
-> StateT Context GititServerPart FileStore
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ServerPartT (ReaderT WikiState IO) FileStore
getFileStore
  Request
req <- GititServerPart Request -> StateT Context GititServerPart Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  let pluginData :: PluginData
pluginData = PluginData :: Config -> Maybe User -> Request -> FileStore -> PluginData
PluginData{ pluginConfig :: Config
pluginConfig = Config
conf
                             , pluginUser :: Maybe User
pluginUser = Maybe User
user
                             , pluginRequest :: Request
pluginRequest = Request
req
                             , pluginFileStore :: FileStore
pluginFileStore = FileStore
fs }
  (a
result', Context
context') <- IO (a, Context) -> StateT Context GititServerPart (a, Context)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Context) -> StateT Context GititServerPart (a, Context))
-> IO (a, Context) -> StateT Context GititServerPart (a, Context)
forall a b. (a -> b) -> a -> b
$ PluginM a -> PluginData -> Context -> IO (a, Context)
forall a. PluginM a -> PluginData -> Context -> IO (a, Context)
runPluginM (a -> PluginM a
transform a
inp) PluginData
pluginData Context
context
  Context -> ContentTransformer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Context
context'
  a -> ContentTransformer a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result'

-- | Applies all the page transform plugins to a Pandoc document.
applyPageTransforms :: Pandoc -> ContentTransformer Pandoc
applyPageTransforms :: Pandoc -> StateT Context GititServerPart Pandoc
applyPageTransforms Pandoc
c = do
  [Pandoc -> PluginM Pandoc]
xforms <- ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms
  (Pandoc
 -> (Pandoc -> PluginM Pandoc)
 -> StateT Context GititServerPart Pandoc)
-> Pandoc
-> [Pandoc -> PluginM Pandoc]
-> StateT Context GititServerPart Pandoc
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Pandoc
-> (Pandoc -> PluginM Pandoc)
-> StateT Context GititServerPart Pandoc
forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform Pandoc
c (Pandoc -> PluginM Pandoc
wikiLinksTransform (Pandoc -> PluginM Pandoc)
-> [Pandoc -> PluginM Pandoc] -> [Pandoc -> PluginM Pandoc]
forall a. a -> [a] -> [a]
: [Pandoc -> PluginM Pandoc]
xforms)

-- | Applies all the pre-parse transform plugins to a Page object.
applyPreParseTransforms :: Page -> ContentTransformer Page
applyPreParseTransforms :: Page -> StateT Context GititServerPart Page
applyPreParseTransforms Page
page' = ContentTransformer [String -> PluginM String]
getPreParseTransforms ContentTransformer [String -> PluginM String]
-> ([String -> PluginM String]
    -> StateT Context GititServerPart String)
-> StateT Context GititServerPart String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String
 -> (String -> PluginM String)
 -> StateT Context GititServerPart String)
-> String
-> [String -> PluginM String]
-> StateT Context GititServerPart String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM String
-> (String -> PluginM String)
-> StateT Context GititServerPart String
forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform (Page -> String
pageText Page
page') StateT Context GititServerPart String
-> (String -> StateT Context GititServerPart Page)
-> StateT Context GititServerPart Page
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                (\String
t -> Page -> StateT Context GititServerPart Page
forall (m :: * -> *) a. Monad m => a -> m a
return Page
page'{ pageText :: String
pageText = String
t })

-- | Applies all the pre-commit transform plugins to a raw string.
applyPreCommitTransforms :: String -> ContentTransformer String
applyPreCommitTransforms :: String -> StateT Context GititServerPart String
applyPreCommitTransforms String
c = ContentTransformer [String -> PluginM String]
getPreCommitTransforms ContentTransformer [String -> PluginM String]
-> ([String -> PluginM String]
    -> StateT Context GititServerPart String)
-> StateT Context GititServerPart String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String
 -> (String -> PluginM String)
 -> StateT Context GititServerPart String)
-> String
-> [String -> PluginM String]
-> StateT Context GititServerPart String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM String
-> (String -> PluginM String)
-> StateT Context GititServerPart String
forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform String
c

--
-- Content or context augmentation combinators
--

-- | Puts rendered page content into a wikipage div, adding
-- categories.
wikiDivify :: Html -> ContentTransformer Html
wikiDivify :: Html -> StateT Context GititServerPart Html
wikiDivify Html
c = do
  [String]
categories <- (Context -> [String])
-> StateT Context GititServerPart Context
-> StateT Context GititServerPart [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> [String]
ctxCategories StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  String
base' <- GititServerPart String -> StateT Context GititServerPart String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let categoryLink :: String -> Html
categoryLink String
ctg = Html -> Html
li (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
ctg] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
ctg)
  let htmlCategories :: Html
htmlCategories = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
categories
                          then Html
noHtml
                          else 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
<< (String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map String -> Html
categoryLink [String]
categories
  Html -> StateT Context GititServerPart Html
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> StateT Context GititServerPart Html)
-> Html -> StateT Context GititServerPart Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
thediv (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"wikipage"] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Html
c, Html
htmlCategories]

-- | Adds page title to a Pandoc document.
addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc
addPageTitleToPandoc :: String -> Pandoc -> StateT Context GititServerPart Pandoc
addPageTitleToPandoc String
title' (Pandoc Meta
_ [Block]
blocks) = do
  (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout ((PageLayout -> PageLayout) -> ContentTransformer ())
-> (PageLayout -> PageLayout) -> ContentTransformer ()
forall a b. (a -> b) -> a -> b
$ \PageLayout
layout -> PageLayout
layout{ pgTitle :: String
pgTitle = String
title' }
  Pandoc -> StateT Context GititServerPart Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> StateT Context GititServerPart Pandoc)
-> Pandoc -> StateT Context GititServerPart Pandoc
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
title'
              then Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [Block]
blocks
              else Meta -> [Block] -> Pandoc
Pandoc
                    (Text -> Inlines -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
B.setMeta Text
"title" (Text -> Inlines
B.str (String -> Text
T.pack String
title')) Meta
nullMeta)
                    [Block]
blocks

-- | Adds javascript links for math support.
addMathSupport :: a -> ContentTransformer a
addMathSupport :: a -> ContentTransformer a
addMathSupport a
c = do
  Config
conf <- GititServerPart Config -> StateT Context GititServerPart Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout ((PageLayout -> PageLayout) -> ContentTransformer ())
-> (PageLayout -> PageLayout) -> ContentTransformer ()
forall a b. (a -> b) -> a -> b
$ \PageLayout
l ->
    case Config -> MathMethod
mathMethod Config
conf of
         MathMethod
MathML       -> PageLayout -> [String] -> PageLayout
addScripts PageLayout
l [String
"MathMLinHTML.js"]
         WebTeX String
_     -> PageLayout
l
         MathJax String
u    -> PageLayout -> [String] -> PageLayout
addScripts PageLayout
l [String
u]
         MathMethod
RawTeX       -> PageLayout
l
  a -> ContentTransformer a
forall (m :: * -> *) a. Monad m => a -> m a
return a
c

-- | Adds javascripts to page layout.
addScripts :: PageLayout -> [String] -> PageLayout
addScripts :: PageLayout -> [String] -> PageLayout
addScripts PageLayout
layout [String]
scriptPaths =
  PageLayout
layout{ pgScripts :: [String]
pgScripts = [String]
scriptPaths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ PageLayout -> [String]
pgScripts PageLayout
layout }

--
-- ContentTransformer context API
--

getParams :: ContentTransformer Params
getParams :: StateT Context GititServerPart Params
getParams = GititServerPart Params -> StateT Context GititServerPart Params
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Params -> GititServerPart Params) -> GititServerPart Params
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> GititServerPart Params
forall (m :: * -> *) a. Monad m => a -> m a
return)

getFileName :: ContentTransformer FilePath
getFileName :: StateT Context GititServerPart String
getFileName = (Context -> String)
-> StateT Context GititServerPart Context
-> StateT Context GititServerPart String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> String
ctxFile StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get

getPageName :: ContentTransformer String
getPageName :: StateT Context GititServerPart String
getPageName = (Context -> String)
-> StateT Context GititServerPart Context
-> StateT Context GititServerPart String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PageLayout -> String
pgPageName (PageLayout -> String)
-> (Context -> PageLayout) -> Context -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> PageLayout
ctxLayout) StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get

getLayout :: ContentTransformer PageLayout
getLayout :: ContentTransformer PageLayout
getLayout = (Context -> PageLayout)
-> StateT Context GititServerPart Context
-> ContentTransformer PageLayout
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> PageLayout
ctxLayout StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get

getCacheable :: ContentTransformer Bool
getCacheable :: ContentTransformer Bool
getCacheable = (Context -> Bool)
-> StateT Context GititServerPart Context
-> ContentTransformer Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxCacheable StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get

-- | Updates the layout with the result of applying f to the current layout
updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout PageLayout -> PageLayout
f = do
  Context
ctx <- StateT Context GititServerPart Context
forall s (m :: * -> *). MonadState s m => m s
get
  let l :: PageLayout
l = Context -> PageLayout
ctxLayout Context
ctx
  Context -> ContentTransformer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Context
ctx { ctxLayout :: PageLayout
ctxLayout = PageLayout -> PageLayout
f PageLayout
l }

--
-- Pandoc and wiki content conversion support
--

readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc
readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc
readerFor PageType
pt Bool
lhs =
  let defExts :: Extensions
defExts = Text -> Extensions
getDefaultExtensions (Text -> Extensions) -> Text -> Extensions
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PageType -> String
forall a. Show a => a -> String
show PageType
pt
      defPS :: ReaderOptions
defPS = ReaderOptions
forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = Extensions
defExts
                                      Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> [Extension] -> Extensions
extensionsFromList [Extension
Ext_emoji]
                                      Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> PageType -> Bool -> Extensions
getPageTypeDefaultExtensions PageType
pt Bool
lhs
                                      Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> ReaderOptions -> Extensions
readerExtensions ReaderOptions
forall a. Default a => a
def }
  in PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (String -> PandocPure Pandoc)
-> String
-> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case PageType
pt of
       PageType
RST        -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
defPS
       PageType
Markdown   -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
defPS
       PageType
CommonMark -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readCommonMark ReaderOptions
defPS
       PageType
LaTeX      -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readLaTeX ReaderOptions
defPS
       PageType
HTML       -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readHtml ReaderOptions
defPS
       PageType
Textile    -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readTextile ReaderOptions
defPS
       PageType
Org        -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOrg ReaderOptions
defPS
       PageType
DocBook    -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readDocBook ReaderOptions
defPS
       PageType
MediaWiki  -> ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMediaWiki ReaderOptions
defPS) (Text -> PandocPure Pandoc)
-> (String -> Text) -> String -> PandocPure Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

wikiLinksTransform :: Pandoc -> PluginM Pandoc
wikiLinksTransform :: Pandoc -> PluginM Pandoc
wikiLinksTransform Pandoc
pandoc
  = do Config
cfg <- (PluginData -> Config)
-> ReaderT PluginData (StateT Context IO) PluginData
-> ReaderT PluginData (StateT Context IO) Config
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PluginData -> Config
pluginConfig ReaderT PluginData (StateT Context IO) PluginData
forall r (m :: * -> *). MonadReader r m => m r
ask -- Can't use askConfig from Interface due to circular dependencies.
       Pandoc -> PluginM Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return ((Inline -> Inline) -> Pandoc -> Pandoc
forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp (Config -> Inline -> Inline
convertWikiLinks Config
cfg) Pandoc
pandoc)

-- | Convert links with no URL to wikilinks.
convertWikiLinks :: Config -> Inline -> Inline
convertWikiLinks :: Config -> Inline -> Inline
convertWikiLinks Config
cfg (Link Attr
attr [Inline]
ref (Text
"", Text
"")) | Config -> Bool
useAbsoluteUrls Config
cfg =
  Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ref (String -> Text
T.pack (String
"/" String -> String -> String
</> Config -> String
baseUrl Config
cfg String -> String -> String
</> [Inline] -> String
inlinesToURL [Inline]
ref),
                 Text
"Go to wiki page")
convertWikiLinks Config
_cfg (Link Attr
attr [Inline]
ref (Text
"", Text
"")) =
  Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ref (String -> Text
T.pack ([Inline] -> String
inlinesToURL [Inline]
ref), Text
"Go to wiki page")
convertWikiLinks Config
_cfg Inline
x = Inline
x

-- | Derives a URL from a list of Pandoc Inline elements.
inlinesToURL :: [Inline] -> String
inlinesToURL :: [Inline] -> String
inlinesToURL = Bool -> (Char -> Bool) -> String -> String
encString Bool
False Char -> Bool
isUnescapedInURI (String -> String) -> ([Inline] -> String) -> [Inline] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> String
inlinesToString

-- | Convert a list of inlines into a string.
inlinesToString :: [Inline] -> String
inlinesToString :: [Inline] -> String
inlinesToString = Text -> String
T.unpack (Text -> String) -> ([Inline] -> Text) -> [Inline] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Inline] -> [Text]) -> [Inline] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go
  where go :: Inline -> T.Text
        go :: Inline -> Text
go Inline
x = case Inline
x of
               Str Text
s                   -> Text
s
               Emph [Inline]
xs                 -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Strong [Inline]
xs               -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Strikeout [Inline]
xs            -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Superscript [Inline]
xs          -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Subscript [Inline]
xs            -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               SmallCaps [Inline]
xs            -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
#if MIN_VERSION_pandoc(2,10,0)
               Underline [Inline]
xs            -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
#endif
               Quoted QuoteType
DoubleQuote [Inline]
xs   -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ((Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
               Quoted QuoteType
SingleQuote [Inline]
xs   -> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ((Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
               Cite [Citation]
_ [Inline]
xs               -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Code Attr
_ Text
s                -> Text
s
               Inline
Space                   -> Text
" "
               Inline
SoftBreak               -> Text
" "
               Inline
LineBreak               -> Text
" "
               Math MathType
DisplayMath Text
s      -> Text
"$$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$$"
               Math MathType
InlineMath Text
s       -> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$"
               RawInline (Format Text
"tex") Text
s -> Text
s
               RawInline Format
_ Text
_           -> Text
""
               Link Attr
_ [Inline]
xs (Text, Text)
_             -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Image Attr
_ [Inline]
xs (Text, Text)
_            -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Note [Block]
_                  -> Text
""
               Span Attr
_ [Inline]
xs               -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> Text) -> [Inline] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs