    {-# LANGUAGE ScopedTypeVariables #-}
    {-
    Copyright (C) 2009 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
    -}

    {- | Useful functions for defining wiki handlers.
    -}

    module Network.Gitit.Framework (
                                   -- * Combinators for dealing with users
                                     withUserFromSession
                                   , withUserFromHTTPAuth
                                   , authenticateUserThat
                                   , authenticate
                                   , getLoggedInUser
                                   -- * Combinators to exclude certain actions
                                   , unlessNoEdit
                                   , unlessNoDelete
                                   -- * Guards for routing
                                   , guardCommand
                                   , guardPath
                                   , guardIndex
                                   , guardBareBase
                                   -- * Functions to get info from the request
                                   , getPath
                                   , getPage
                                   , getReferer
                                   , getWikiBase
                                   , uriPath
                                   -- * Useful predicates
                                   , isPage
                                   , isPageFile
                                   , isDiscussPage
                                   , isDiscussPageFile
                                   , isNotDiscussPageFile
                                   , isSourceCode
                                   -- * Combinators that change the request locally
                                   , withMessages
                                   -- * Miscellaneous
                                   , urlForPage
                                   , pathForPage
                                   , getMimeTypeForExtension
                                   , validate
                                   , filestoreFromConfig
                                   , mkSessionCookie
                                   )
    where
    import Safe
    import Network.Gitit.Server
    import Network.Gitit.State
    import Network.Gitit.Types
    import Data.FileStore
    import Data.Char (toLower)
    import Control.Monad (mzero, liftM, unless)
    import qualified Data.Map as M
    import qualified Data.ByteString.UTF8 as UTF8
    import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8
    import Skylighting (syntaxesByFilename, defaultSyntaxMap)
    import Data.Maybe (fromJust, fromMaybe)
    import Data.List (intercalate, isPrefixOf, isInfixOf)
    import System.FilePath ((<.>), takeExtension, takeFileName)
    import Text.ParserCombinators.Parsec
    import Network.URL (decString, encString)
    import Network.URI (isUnescapedInURI)
    import Data.ByteString.Base64 (decodeLenient)
    import Network.HTTP (urlEncodeVars)

    -- | Require a logged in user if the authentication level demands it.
    -- Run the handler if a user is logged in, otherwise redirect
    -- to login page.
    authenticate :: AuthenticationLevel -> Handler -> Handler
    authenticate :: AuthenticationLevel -> Handler -> Handler
    authenticate = (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
    authenticateUserThat (Bool -> User -> Bool
    forall a b. a -> b -> a
    const Bool
    True)

    -- | Like 'authenticate', but with a predicate that the user must satisfy.
    authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
    authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
    authenticateUserThat User -> Bool
    predicate AuthenticationLevel
    level Handler
    handler = do
      cfg <- GititServerPart Config
    getConfig
      if level <= requireAuthentication cfg
         then do
           mbUser <- getLoggedInUser
           rq <- askRq
           let url = Request -> String
    rqUri Request
    rq String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Request -> String
    rqQuery Request
    rq
           case mbUser of
                Maybe User
    Nothing   -> String -> Response -> Handler
    forall (m :: * -> *) a res.
    (FilterMonad Response m, ToSURI a) =>
    a -> res -> m res
    tempRedirect (String
    "/_login?" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [(String, String)] -> String
    urlEncodeVars [(String
    "destination", String
    url)]) (Response -> Handler) -> Response -> Handler
    forall a b. (a -> b) -> a -> b
    $ () -> Response
    forall a. ToMessage a => a -> Response
    toResponse ()
                Just User
    u    -> if User -> Bool
    predicate User
    u
                                then Handler
    handler
                                else String -> Handler
    forall a. Partial => String -> a
    error String
    "Not authorized."
         else handler

    -- | Run the handler after setting @REMOTE_USER@ with the user from
    -- the session.
    withUserFromSession :: Handler -> Handler
    withUserFromSession :: Handler -> Handler
    withUserFromSession Handler
    handler = (Maybe SessionKey -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Maybe SessionKey -> Handler) -> Handler)
    -> (Maybe SessionKey -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \(Maybe SessionKey
    mbsk :: Maybe SessionKey) -> do
      mbSd <- ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
    -> (SessionKey
        -> ServerPartT (ReaderT WikiState IO) (Maybe SessionData))
    -> Maybe SessionKey
    -> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Maybe SessionData
    -> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing) SessionKey
    -> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
    forall (m :: * -> *).
    MonadIO m =>
    SessionKey -> m (Maybe SessionData)
    getSession Maybe SessionKey
    mbsk
      cfg <- getConfig
      mbUser <- case mbSd of
                Maybe SessionData
    Nothing    -> Maybe User -> GititServerPart (Maybe User)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe User
    forall a. Maybe a
    Nothing
                Just SessionData
    sd    -> do
                  case Maybe SessionKey
    mbsk of
                    Maybe SessionKey
    Nothing -> () -> ServerPartT (ReaderT WikiState IO) ()
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                    Just SessionKey
    sk ->
                      CookieLife -> Cookie -> ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *).
    (MonadIO m, FilterMonad Response m) =>
    CookieLife -> Cookie -> m ()
    addCookie (Int -> CookieLife
    MaxAge (Int -> CookieLife) -> Int -> CookieLife
    forall a b. (a -> b) -> a -> b
    $ Config -> Int
    sessionTimeout Config
    cfg) -- refresh timeout
                                (SessionKey -> Cookie
    mkSessionCookie SessionKey
    sk)
                  case SessionData -> Maybe String
    sessionUser SessionData
    sd of
                    Maybe String
    Nothing -> Maybe User -> GititServerPart (Maybe User)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe User
    forall a. Maybe a
    Nothing
                    Just String
    user -> String -> GititServerPart (Maybe User)
    getUser String
    user
      let user = String -> (User -> String) -> Maybe User -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String
    "" User -> String
    uUsername Maybe User
    mbUser
      localRq (setHeader "REMOTE_USER" user) handler

    -- | Run the handler after setting @REMOTE_USER@ from the "authorization"
    -- header.  Works with simple HTTP authentication or digest authentication.
    withUserFromHTTPAuth :: Handler -> Handler
    withUserFromHTTPAuth :: Handler -> Handler
    withUserFromHTTPAuth Handler
    handler = do
      req <- ServerPartT (ReaderT WikiState IO) Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      let user = case String -> Request -> Maybe ByteString
    forall r. HasHeaders r => String -> r -> Maybe ByteString
    getHeader String
    "authorization" Request
    req of
                  Maybe ByteString
    Nothing         -> String
    ""
                  Just ByteString
    authHeader -> case Parsec String () String
    -> String -> String -> Either ParseError String
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> String -> s -> Either ParseError a
    parse Parsec String () String
    forall st. GenParser Char st String
    pAuthorizationHeader String
    "" (ByteString -> String
    UTF8.toString ByteString
    authHeader) of
                                      Left ParseError
    _  -> String
    ""
                                      Right String
    u -> String
    u
      localRq (setHeader "REMOTE_USER" user) handler

    -- | Returns @Just@ logged in user or @Nothing@.
    getLoggedInUser :: GititServerPart (Maybe User)
    getLoggedInUser :: GititServerPart (Maybe User)
    getLoggedInUser = do
      req <- ServerPartT (ReaderT WikiState IO) Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      case maybe "" UTF8.toString (getHeader "REMOTE_USER" req) of
            String
    "" -> Maybe User -> GititServerPart (Maybe User)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe User
    forall a. Maybe a
    Nothing
            String
    u  -> do
              mbUser <- String -> GititServerPart (Maybe User)
    getUser String
    u
              case mbUser of
                   Just User
    user -> Maybe User -> GititServerPart (Maybe User)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe User -> GititServerPart (Maybe User))
    -> Maybe User -> GititServerPart (Maybe User)
    forall a b. (a -> b) -> a -> b
    $ User -> Maybe User
    forall a. a -> Maybe a
    Just User
    user
                   Maybe User
    Nothing   -> Maybe User -> GititServerPart (Maybe User)
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe User -> GititServerPart (Maybe User))
    -> Maybe User -> GititServerPart (Maybe User)
    forall a b. (a -> b) -> a -> b
    $ User -> Maybe User
    forall a. a -> Maybe a
    Just User{uUsername :: String
    uUsername = String
    u, uEmail :: String
    uEmail = String
    "", uPassword :: Password
    uPassword = Password
    forall a. Partial => a
    undefined}

    pAuthorizationHeader :: GenParser Char st String
    pAuthorizationHeader :: forall st. GenParser Char st String
    pAuthorizationHeader = GenParser Char st String -> GenParser Char st String
    forall tok st a. GenParser tok st a -> GenParser tok st a
    try GenParser Char st String
    forall st. GenParser Char st String
    pBasicHeader GenParser Char st String
    -> GenParser Char st String -> GenParser Char st String
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    <|> GenParser Char st String
    forall st. GenParser Char st String
    pDigestHeader

    pDigestHeader :: GenParser Char st String
    pDigestHeader :: forall st. GenParser Char st String
    pDigestHeader = do
      _ <- String -> ParsecT String st Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string String
    "Digest username=\""
      result' <- many (noneOf "\"")
      _ <- char '"'
      return result'

    pBasicHeader :: GenParser Char st String
    pBasicHeader :: forall st. GenParser Char st String
    pBasicHeader = do
      _ <- String -> ParsecT String st Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string String
    "Basic "
      result' <- many (noneOf " \t\n")
      return $ takeWhile (/=':') $ UTF8.toString
             $ decodeLenient $ UTF8.fromString result'

    -- | @unlessNoEdit responder fallback@ runs @responder@ unless the
    -- page has been designated not editable in configuration; in that
    -- case, runs @fallback@.
    unlessNoEdit :: Handler
                 -> Handler
                 -> Handler
    unlessNoEdit :: Handler -> Handler -> Handler
    unlessNoEdit Handler
    responder Handler
    fallback = (Params -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \(Params
    params :: Params) -> do
      cfg <- GititServerPart Config
    getConfig
      page <- getPage
      if page `elem` noEdit cfg
         then withMessages ("Page is locked." : pMessages params) fallback
         else responder

    -- | @unlessNoDelete responder fallback@ runs @responder@ unless the
    -- page has been designated not deletable in configuration; in that
    -- case, runs @fallback@.
    unlessNoDelete :: Handler
                   -> Handler
                   -> Handler
    unlessNoDelete :: Handler -> Handler -> Handler
    unlessNoDelete Handler
    responder Handler
    fallback = (Params -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \(Params
    params :: Params) -> do
      cfg <- GititServerPart Config
    getConfig
      page <- getPage
      if page `elem` noDelete cfg
         then withMessages ("Page cannot be deleted." : pMessages params) fallback
         else responder

    -- | Returns the current path (subtracting initial commands like @\/_edit@).
    getPath :: ServerMonad m => m String
    getPath :: forall (m :: * -> *). ServerMonad m => m String
    getPath = (Request -> String) -> m Request -> m String
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "/" ([String] -> String) -> (Request -> [String]) -> Request -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> [String]
    rqPaths) m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq

    -- | Returns the current page name (derived from the path).
    getPage :: GititServerPart String
    getPage :: GititServerPart String
    getPage = do
      conf <- GititServerPart Config
    getConfig
      path' <- getPath
      if null path'
         then return (frontPage conf)
         else if isPage path'
                 then return path'
                 else mzero  -- fail if not valid page name

    -- | Returns the contents of the "referer" header.
    getReferer :: ServerMonad m => m String
    getReferer :: forall (m :: * -> *). ServerMonad m => m String
    getReferer = do
      req <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      base' <- getWikiBase
      return $ case getHeader "referer" req of
                     Just ByteString
    r  -> case ByteString -> String
    UTF8.toString ByteString
    r of
                                     String
    ""  -> String
    base'
                                     String
    s   -> String
    s
                     Maybe ByteString
    Nothing -> String
    base'

    -- | Returns the base URL of the wiki in the happstack server.
    -- So, if the wiki handlers are behind a @dir 'foo'@, getWikiBase will
    -- return @\/foo/@.  getWikiBase doesn't know anything about HTTP
    -- proxies, so if you use proxies to map a gitit wiki to @\/foo/@,
    -- you'll still need to follow the instructions in README.
    getWikiBase :: ServerMonad m => m String
    getWikiBase :: forall (m :: * -> *). ServerMonad m => m String
    getWikiBase = do
      path' <- m String
    forall (m :: * -> *). ServerMonad m => m String
    getPath
      uri' <- liftM (fromJust . decString True . rqUri) askRq
      case calculateWikiBase path' uri' of
           Just String
    b    -> String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    b
           Maybe String
    Nothing   -> String -> m String
    forall a. Partial => String -> a
    error (String -> m String) -> String -> m String
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not getWikiBase: (path, uri) = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (String, String) -> String
    forall a. Show a => a -> String
    show (String
    path',String
    uri')

    -- | The pure core of 'getWikiBase'.
    calculateWikiBase :: String -> String -> Maybe String
    calculateWikiBase :: String -> String -> Maybe String
    calculateWikiBase String
    path' String
    uri' =
      let revpaths :: [String]
    revpaths = [String] -> [String]
    forall a. [a] -> [a]
    reverse ([String] -> [String])
    -> ([String] -> [String]) -> [String] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ Char -> String -> [String]
    forall a. Eq a => a -> [a] -> [[a]]
    splitOn Char
    '/' String
    path'
          revuris :: [String]
    revuris  = [String] -> [String]
    forall a. [a] -> [a]
    reverse ([String] -> [String])
    -> ([String] -> [String]) -> [String] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ Char -> String -> [String]
    forall a. Eq a => a -> [a] -> [[a]]
    splitOn Char
    '/' String
    uri'
      in  if [String]
    revpaths [String] -> [String] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` [String]
    revuris
             then let revbase :: [String]
    revbase = Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    drop ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    revpaths) [String]
    revuris
                      -- a path like _feed is not part of the base...
                      revbase' :: [String]
    revbase' = case [String]
    revbase of
                                 (String
    x:[String]
    xs) | String -> Bool
    startsWithUnderscore String
    x -> [String]
    xs
                                 [String]
    xs                              -> [String]
    xs
                      base' :: String
    base'    = String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "/" ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [String] -> [String]
    forall a. [a] -> [a]
    reverse [String]
    revbase'
                  in  String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    base' then String
    "" else Char
    '/' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    base'
              else Maybe String
    forall a. Maybe a
    Nothing

    startsWithUnderscore :: String -> Bool
    startsWithUnderscore :: String -> Bool
    startsWithUnderscore (Char
    '_':String
    _) = Bool
    True
    startsWithUnderscore String
    _ = Bool
    False

    splitOn :: Eq a => a -> [a] -> [[a]]
    splitOn :: forall a. Eq a => a -> [a] -> [[a]]
    splitOn a
    c [a]
    cs =
      let ([a]
    next, [a]
    rest) = (a -> Bool) -> [a] -> ([a], [a])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    ==a
    c) [a]
    cs
      in case [a]
    rest of
             []     -> [[a]
    next]
             (a
    _:[a]
    rs) -> [a]
    next [a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    : a -> [a] -> [[a]]
    forall a. Eq a => a -> [a] -> [[a]]
    splitOn a
    c [a]
    rs

    -- | Returns path portion of URI, without initial @\/@.
    -- Consecutive spaces are collapsed.  We don't want to distinguish
    -- @Hi There@ and @Hi  There@.
    uriPath :: String -> String
    uriPath :: String -> String
    uriPath = [String] -> String
    unwords ([String] -> String) -> (String -> [String]) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    words (String -> [String]) -> (String -> String) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    1 (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Char
    '?')

    isPage :: String -> Bool
    isPage :: String -> Bool
    isPage String
    "" = Bool
    False
    isPage (Char
    '_':String
    _) = Bool
    False
    isPage String
    s = (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> String -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` String
    "*?") String
    s Bool -> Bool -> Bool
    && Bool -> Bool
    not (String
    ".." String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` String
    s) Bool -> Bool -> Bool
    && Bool -> Bool
    not (String
    "/_" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` String
    s)
    -- for now, we disallow @*@ and @?@ in page names, because git filestore
    -- does not deal with them properly, and darcs filestore disallows them.

    isPageFile :: FilePath -> GititServerPart Bool
    isPageFile :: String -> GititServerPart Bool
    isPageFile String
    f = do
      cfg <- GititServerPart Config
    getConfig
      return $ takeExtension f == "." ++ (defaultExtension cfg)

    isDiscussPage :: String -> Bool
    isDiscussPage :: String -> Bool
    isDiscussPage (Char
    '@':String
    xs) = String -> Bool
    isPage String
    xs
    isDiscussPage String
    _ = Bool
    False

    isDiscussPageFile :: FilePath -> GititServerPart Bool
    isDiscussPageFile :: String -> GititServerPart Bool
    isDiscussPageFile (Char
    '@':String
    xs) = String -> GititServerPart Bool
    isPageFile String
    xs
    isDiscussPageFile String
    _ = Bool -> GititServerPart Bool
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    isNotDiscussPageFile :: FilePath -> GititServerPart Bool
    isNotDiscussPageFile :: String -> GititServerPart Bool
    isNotDiscussPageFile (Char
    '@':String
    _) = Bool -> GititServerPart Bool
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    isNotDiscussPageFile String
    _ = Bool -> GititServerPart Bool
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True

    isSourceCode :: String -> Bool
    isSourceCode :: String -> Bool
    isSourceCode String
    path' =
      let langs :: [Syntax]
    langs = SyntaxMap -> String -> [Syntax]
    syntaxesByFilename SyntaxMap
    defaultSyntaxMap (String -> [Syntax]) -> String -> [Syntax]
    forall a b. (a -> b) -> a -> b
    $ String -> String
    takeFileName String
    path'
          ext :: String
    ext = String -> String
    takeExtension String
    path'
      in  Bool -> Bool
    not ([Syntax] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Syntax]
    langs Bool -> Bool -> Bool
    || String
    ext String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    ".svg" Bool -> Bool -> Bool
    || String
    ext String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    ".eps")
                             -- allow svg or eps to be served as image

    -- | Returns encoded URL path for the page with the given name, relative to
    -- the wiki base.
    urlForPage :: String -> String
    urlForPage :: String -> String
    urlForPage String
    page = Char
    '/' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Bool -> (Char -> Bool) -> String -> String
    encString Bool
    False Char -> Bool
    isUnescapedInURI String
    page

    -- | Returns the filestore path of the file containing the page's source.
    pathForPage :: String -> String -> FilePath
    pathForPage :: String -> String -> String
    pathForPage String
    page String
    ext = String
    page String -> String -> String
    <.> String
    ext

    -- | Retrieves a mime type based on file extension.
    getMimeTypeForExtension :: String -> GititServerPart String
    getMimeTypeForExtension :: String -> GititServerPart String
    getMimeTypeForExtension String
    ext = do
      mimes <- (Config -> Map String String)
    -> GititServerPart Config
    -> ServerPartT (ReaderT WikiState IO) (Map String String)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Config -> Map String String
    mimeMap GititServerPart Config
    getConfig
      return $ fromMaybe "application/octet-stream"
        (M.lookup (dropWhile (== '.') $ map toLower ext) mimes)

    -- | Simple helper for validation of forms.
    validate :: [(Bool, String)]   -- ^ list of conditions and error messages
             -> [String]           -- ^ list of error messages
    validate :: [(Bool, String)] -> [String]
    validate = ([String] -> (Bool, String) -> [String])
    -> [String] -> [(Bool, String)] -> [String]
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl [String] -> (Bool, String) -> [String]
    forall {a}. [a] -> (Bool, a) -> [a]
    go []
       where go :: [a] -> (Bool, a) -> [a]
    go [a]
    errs (Bool
    condition, a
    msg) = if Bool
    condition then a
    msga -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    errs else [a]
    errs

    guardCommand :: String -> GititServerPart ()
    guardCommand :: String -> ServerPartT (ReaderT WikiState IO) ()
    guardCommand String
    command = (Command -> ServerPartT (ReaderT WikiState IO) ())
    -> ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Command -> ServerPartT (ReaderT WikiState IO) ())
     -> ServerPartT (ReaderT WikiState IO) ())
    -> (Command -> ServerPartT (ReaderT WikiState IO) ())
    -> ServerPartT (ReaderT WikiState IO) ()
    forall a b. (a -> b) -> a -> b
    $ \(Command
    com :: Command) ->
      case Command
    com of
           Command (Just String
    c) | String
    c String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    command -> () -> ServerPartT (ReaderT WikiState IO) ()
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
           Command
    _                               -> ServerPartT (ReaderT WikiState IO) ()
    forall a. ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero

    guardPath :: (String -> Bool) -> GititServerPart ()
    guardPath :: (String -> Bool) -> ServerPartT (ReaderT WikiState IO) ()
    guardPath String -> Bool
    pred' = (Request -> Bool) -> ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *).
    (ServerMonad m, MonadPlus m) =>
    (Request -> Bool) -> m ()
    guardRq (String -> Bool
    pred' (String -> Bool) -> (Request -> String) -> Request -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> String
    rqUri)

    -- | Succeeds if path is an index path:  e.g. @\/foo\/bar/@.
    guardIndex :: GititServerPart ()
    guardIndex :: ServerPartT (ReaderT WikiState IO) ()
    guardIndex = do
      base <- GititServerPart String
    forall (m :: * -> *). ServerMonad m => m String
    getWikiBase
      uri' <- liftM rqUri askRq
      let localpath = Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    base) String
    uri'
      unless (length localpath > 1 && lastNote "guardIndex" uri' == '/')
        mzero

    -- Guard against a path like @\/wiki@ when the wiki is being
    -- served at @\/wiki@.
    guardBareBase :: GititServerPart ()
    guardBareBase :: ServerPartT (ReaderT WikiState IO) ()
    guardBareBase = do
      base' <- GititServerPart String
    forall (m :: * -> *). ServerMonad m => m String
    getWikiBase
      uri' <- liftM rqUri askRq
      unless (not (null base') && base' == uri')
        mzero

    -- | Runs a server monad in a local context after setting
    -- the "message" request header.
    withMessages :: ServerMonad m => [String] -> m a -> m a
    withMessages :: forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
    withMessages [String]
    messages m a
    handler = do
      req <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      let inps = ((String, Input) -> Bool) -> [(String, Input)] -> [(String, Input)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(String
    n,Input
    _) -> String
    n String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    "message") ([(String, Input)] -> [(String, Input)])
    -> [(String, Input)] -> [(String, Input)]
    forall a b. (a -> b) -> a -> b
    $ Request -> [(String, Input)]
    rqInputsQuery Request
    req
      let newInp String
    msg = (String
    "message", Input {
                                  inputValue :: Either String ByteString
    inputValue = ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right
                                             (ByteString -> Either String ByteString)
    -> ByteString -> Either String ByteString
    forall a b. (a -> b) -> a -> b
    $ String -> ByteString
    LazyUTF8.fromString String
    msg
                                , inputFilename :: Maybe String
    inputFilename = Maybe String
    forall a. Maybe a
    Nothing
                                , inputContentType :: ContentType
    inputContentType = ContentType {
                                        ctType :: String
    ctType = String
    "text"
                                      , ctSubtype :: String
    ctSubtype = String
    "plain"
                                      , ctParameters :: [(String, String)]
    ctParameters = [] }
                                })
      localRq (\Request
    rq -> Request
    rq{ rqInputsQuery = map newInp messages ++ inps }) handler

    -- | Returns a filestore object derived from the
    -- repository path and filestore type specified in configuration.
    filestoreFromConfig :: Config -> FileStore
    filestoreFromConfig :: Config -> FileStore
    filestoreFromConfig Config
    conf =
      case Config -> FileStoreType
    repositoryType Config
    conf of
             FileStoreType
    Git       -> String -> FileStore
    gitFileStore       (String -> FileStore) -> String -> FileStore
    forall a b. (a -> b) -> a -> b
    $ Config -> String
    repositoryPath Config
    conf
             FileStoreType
    Darcs     -> String -> FileStore
    darcsFileStore     (String -> FileStore) -> String -> FileStore
    forall a b. (a -> b) -> a -> b
    $ Config -> String
    repositoryPath Config
    conf
             FileStoreType
    Mercurial -> String -> FileStore
    mercurialFileStore (String -> FileStore) -> String -> FileStore
    forall a b. (a -> b) -> a -> b
    $ Config -> String
    repositoryPath Config
    conf

    -- Create a cookie with the session key.
    mkSessionCookie :: SessionKey -> Cookie
    mkSessionCookie :: SessionKey -> Cookie
    mkSessionCookie (SessionKey Integer
    key) = String -> String -> Cookie
    mkCookie String
    "sid" (Integer -> String
    forall a. Show a => a -> String
    show Integer
    key)