    {-# 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
                                   )
    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 predicate :: User -> Bool
    predicate level :: AuthenticationLevel
    level handler :: Handler
    handler = do
      Config
    cfg <- GititServerPart Config
    getConfig
      if AuthenticationLevel
    level AuthenticationLevel -> AuthenticationLevel -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Config -> AuthenticationLevel
    requireAuthentication Config
    cfg
         then do
           Maybe User
    mbUser <- GititServerPart (Maybe User)
    getLoggedInUser
           Request
    rq <- ServerPartT (ReaderT WikiState IO) Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
           let url :: [Char]
    url = Request -> [Char]
    rqUri Request
    rq [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Request -> [Char]
    rqQuery Request
    rq
           case Maybe User
    mbUser of
                Nothing   -> [Char] -> Response -> Handler
    forall (m :: * -> *) a res.
    (FilterMonad Response m, ToSURI a) =>
    a -> res -> m res
    tempRedirect ("/_login?" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [([Char], [Char])] -> [Char]
    urlEncodeVars [("destination", [Char]
    url)]) (Response -> Handler) -> Response -> Handler
    forall a b. (a -> b) -> a -> b
    $ () -> Response
    forall a. ToMessage a => a -> Response
    toResponse ()
                Just u :: User
    u    -> if User -> Bool
    predicate User
    u
                                then Handler
    handler
                                else [Char] -> Handler
    forall a. HasCallStack => [Char] -> a
    error "Not authorized."
         else Handler
    handler

    -- | Run the handler after setting @REMOTE_USER@ with the user from
    -- the session.
    withUserFromSession :: Handler -> Handler
    withUserFromSession :: Handler -> Handler
    withUserFromSession handler :: 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
    sk :: Maybe SessionKey) -> do
      Maybe SessionData
    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 (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
    sk
      Config
    cfg <- GititServerPart Config
    getConfig
      Maybe User
    mbUser <- case Maybe SessionData
    mbSd of
                Nothing    -> Maybe User -> GititServerPart (Maybe User)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe User
    forall a. Maybe a
    Nothing
                Just sd :: SessionData
    sd    -> do
                  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) ([Char] -> [Char] -> Cookie
    mkCookie "sid" (SessionKey -> [Char]
    forall a. Show a => a -> [Char]
    show (SessionKey -> [Char]) -> SessionKey -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Maybe SessionKey -> SessionKey
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe SessionKey
    sk))  -- refresh timeout
                  case SessionData -> Maybe [Char]
    sessionUser SessionData
    sd of
                    Nothing -> Maybe User -> GititServerPart (Maybe User)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe User
    forall a. Maybe a
    Nothing
                    Just user :: [Char]
    user -> [Char] -> GititServerPart (Maybe User)
    getUser [Char]
    user
      let user :: [Char]
    user = [Char] -> (User -> [Char]) -> Maybe User -> [Char]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe "" User -> [Char]
    uUsername Maybe User
    mbUser
      (Request -> Request) -> Handler -> Handler
    forall (m :: * -> *) a.
    ServerMonad m =>
    (Request -> Request) -> m a -> m a
    localRq ([Char] -> [Char] -> Request -> Request
    forall r. HasHeaders r => [Char] -> [Char] -> r -> r
    setHeader "REMOTE_USER" [Char]
    user) Handler
    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
    handler = do
      Request
    req <- ServerPartT (ReaderT WikiState IO) Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      let user :: [Char]
    user = case [Char] -> Request -> Maybe ByteString
    forall r. HasHeaders r => [Char] -> r -> Maybe ByteString
    getHeader "authorization" Request
    req of
                  Nothing         -> ""
                  Just authHeader :: ByteString
    authHeader -> case Parsec [Char] () [Char]
    -> [Char] -> [Char] -> Either ParseError [Char]
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> [Char] -> s -> Either ParseError a
    parse Parsec [Char] () [Char]
    forall st. GenParser Char st [Char]
    pAuthorizationHeader "" (ByteString -> [Char]
    UTF8.toString ByteString
    authHeader) of
                                      Left _  -> ""
                                      Right u :: [Char]
    u -> [Char]
    u
      (Request -> Request) -> Handler -> Handler
    forall (m :: * -> *) a.
    ServerMonad m =>
    (Request -> Request) -> m a -> m a
    localRq ([Char] -> [Char] -> Request -> Request
    forall r. HasHeaders r => [Char] -> [Char] -> r -> r
    setHeader "REMOTE_USER" [Char]
    user) Handler
    handler

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

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

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

    pBasicHeader :: GenParser Char st String
    pBasicHeader :: GenParser Char st [Char]
    pBasicHeader = do
      [Char]
    _ <- [Char] -> GenParser Char st [Char]
    forall s (m :: * -> *) u.
    Stream s m Char =>
    [Char] -> ParsecT s u m [Char]
    string "Basic "
      [Char]
    result' <- ParsecT [Char] st Identity Char -> GenParser Char st [Char]
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
    many ([Char] -> ParsecT [Char] st Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    [Char] -> ParsecT s u m Char
    noneOf " \t\n")
      [Char] -> GenParser Char st [Char]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Char] -> GenParser Char st [Char])
    -> [Char] -> GenParser Char st [Char]
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> [Char] -> [Char]
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=':') ([Char] -> [Char]) -> [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ ByteString -> [Char]
    UTF8.toString
             (ByteString -> [Char]) -> ByteString -> [Char]
    forall a b. (a -> b) -> a -> b
    $ ByteString -> ByteString
    decodeLenient (ByteString -> ByteString) -> ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ [Char] -> ByteString
    UTF8.fromString [Char]
    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 responder :: Handler
    responder fallback :: 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
      Config
    cfg <- GititServerPart Config
    getConfig
      [Char]
    page <- GititServerPart [Char]
    getPage
      if [Char]
    page [Char] -> [[Char]] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Config -> [[Char]]
    noEdit Config
    cfg
         then [[Char]] -> Handler -> Handler
    forall (m :: * -> *) a. ServerMonad m => [[Char]] -> m a -> m a
    withMessages ("Page is locked." [Char] -> [[Char]] -> [[Char]]
    forall a. a -> [a] -> [a]
    : Params -> [[Char]]
    pMessages Params
    params) Handler
    fallback
         else Handler
    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 responder :: Handler
    responder fallback :: 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
      Config
    cfg <- GititServerPart Config
    getConfig
      [Char]
    page <- GititServerPart [Char]
    getPage
      if [Char]
    page [Char] -> [[Char]] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Config -> [[Char]]
    noDelete Config
    cfg
         then [[Char]] -> Handler -> Handler
    forall (m :: * -> *) a. ServerMonad m => [[Char]] -> m a -> m a
    withMessages ("Page cannot be deleted." [Char] -> [[Char]] -> [[Char]]
    forall a. a -> [a] -> [a]
    : Params -> [[Char]]
    pMessages Params
    params) Handler
    fallback
         else Handler
    responder

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

    -- | Returns the current page name (derived from the path).
    getPage :: GititServerPart String
    getPage :: GititServerPart [Char]
    getPage = do
      Config
    conf <- GititServerPart Config
    getConfig
      [Char]
    path' <- GititServerPart [Char]
    forall (m :: * -> *). ServerMonad m => m [Char]
    getPath
      if [Char] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    path'
         then [Char] -> GititServerPart [Char]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Config -> [Char]
    frontPage Config
    conf)
         else if [Char] -> Bool
    isPage [Char]
    path'
                 then [Char] -> GititServerPart [Char]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Char]
    path'
                 else GititServerPart [Char]
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero  -- fail if not valid page name

    -- | Returns the contents of the "referer" header.
    getReferer :: ServerMonad m => m String
    getReferer :: m [Char]
    getReferer = do
      Request
    req <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      [Char]
    base' <- m [Char]
    forall (m :: * -> *). ServerMonad m => m [Char]
    getWikiBase
      [Char] -> m [Char]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Char] -> m [Char]) -> [Char] -> m [Char]
    forall a b. (a -> b) -> a -> b
    $ case [Char] -> Request -> Maybe ByteString
    forall r. HasHeaders r => [Char] -> r -> Maybe ByteString
    getHeader "referer" Request
    req of
                     Just r :: ByteString
    r  -> case ByteString -> [Char]
    UTF8.toString ByteString
    r of
                                     ""  -> [Char]
    base'
                                     s :: [Char]
    s   -> [Char]
    s
                     Nothing -> [Char]
    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 :: m [Char]
    getWikiBase = do
      [Char]
    path' <- m [Char]
    forall (m :: * -> *). ServerMonad m => m [Char]
    getPath
      [Char]
    uri' <- (Request -> [Char]) -> m Request -> m [Char]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (Maybe [Char] -> [Char]
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe [Char] -> [Char])
    -> (Request -> Maybe [Char]) -> Request -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> [Char] -> Maybe [Char]
    decString Bool
    True ([Char] -> Maybe [Char])
    -> (Request -> [Char]) -> Request -> Maybe [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> [Char]
    rqUri) m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      case [Char] -> [Char] -> Maybe [Char]
    calculateWikiBase [Char]
    path' [Char]
    uri' of
           Just b :: [Char]
    b    -> [Char] -> m [Char]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Char]
    b
           Nothing   -> [Char] -> m [Char]
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> m [Char]) -> [Char] -> m [Char]
    forall a b. (a -> b) -> a -> b
    $ "Could not getWikiBase: (path, uri) = " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ([Char], [Char]) -> [Char]
    forall a. Show a => a -> [Char]
    show ([Char]
    path',[Char]
    uri')

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

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

    splitOn :: Eq a => a -> [a] -> [[a]]
    splitOn :: a -> [a] -> [[a]]
    splitOn c :: a
    c cs :: [a]
    cs =
      let (next :: [a]
    next, rest :: [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]
             (_:rs :: [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 :: [Char] -> [Char]
    uriPath = [[Char]] -> [Char]
    unwords ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> [[Char]]
    words ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [Char] -> [Char]
    forall a. Int -> [a] -> [a]
    drop 1 ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> [Char] -> [Char]
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /='?')

    isPage :: String -> Bool
    isPage :: [Char] -> Bool
    isPage "" = Bool
    False
    isPage ('_':_) = Bool
    False
    isPage s :: [Char]
    s = (Char -> Bool) -> [Char] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> [Char] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` "*?") [Char]
    s Bool -> Bool -> Bool
    && Bool -> Bool
    not (".." [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` [Char]
    s) Bool -> Bool -> Bool
    && Bool -> Bool
    not ("/_" [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` [Char]
    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 :: [Char] -> GititServerPart Bool
    isPageFile f :: [Char]
    f = do
      Config
    cfg <- GititServerPart Config
    getConfig
      Bool -> GititServerPart Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> GititServerPart Bool) -> Bool -> GititServerPart Bool
    forall a b. (a -> b) -> a -> b
    $ [Char] -> [Char]
    takeExtension [Char]
    f [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == "." [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ (Config -> [Char]
    defaultExtension Config
    cfg)

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

    isDiscussPageFile :: FilePath -> GititServerPart Bool
    isDiscussPageFile :: [Char] -> GititServerPart Bool
    isDiscussPageFile ('@':xs :: [Char]
    xs) = [Char] -> GititServerPart Bool
    isPageFile [Char]
    xs
    isDiscussPageFile _ = Bool -> GititServerPart Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    isNotDiscussPageFile :: FilePath -> GititServerPart Bool
    isNotDiscussPageFile :: [Char] -> GititServerPart Bool
    isNotDiscussPageFile ('@':_) = Bool -> GititServerPart Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    isNotDiscussPageFile _ = Bool -> GititServerPart Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True

    isSourceCode :: String -> Bool
    isSourceCode :: [Char] -> Bool
    isSourceCode path' :: [Char]
    path' =
      let langs :: [Syntax]
    langs = SyntaxMap -> [Char] -> [Syntax]
    syntaxesByFilename SyntaxMap
    defaultSyntaxMap ([Char] -> [Syntax]) -> [Char] -> [Syntax]
    forall a b. (a -> b) -> a -> b
    $ [Char] -> [Char]
    takeFileName [Char]
    path'
          ext :: [Char]
    ext = [Char] -> [Char]
    takeExtension [Char]
    path'
      in  Bool -> Bool
    not ([Syntax] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Syntax]
    langs Bool -> Bool -> Bool
    || [Char]
    ext [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == ".svg" Bool -> Bool -> Bool
    || [Char]
    ext [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == ".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 :: [Char] -> [Char]
    urlForPage page :: [Char]
    page = '/' Char -> [Char] -> [Char]
    forall a. a -> [a] -> [a]
    : Bool -> (Char -> Bool) -> [Char] -> [Char]
    encString Bool
    False Char -> Bool
    isUnescapedInURI [Char]
    page

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

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

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

    guardCommand :: String -> GititServerPart ()
    guardCommand :: [Char] -> ServerPartT (ReaderT WikiState IO) ()
    guardCommand command :: [Char]
    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 c :: [Char]
    c) | [Char]
    c [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Char]
    command -> () -> ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
           _                               -> ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero

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

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

    -- Guard against a path like @\/wiki@ when the wiki is being
    -- served at @\/wiki@.
    guardBareBase :: GititServerPart ()
    guardBareBase :: ServerPartT (ReaderT WikiState IO) ()
    guardBareBase = do
      [Char]
    base' <- GititServerPart [Char]
    forall (m :: * -> *). ServerMonad m => m [Char]
    getWikiBase
      [Char]
    uri' <- (Request -> [Char])
    -> ServerPartT (ReaderT WikiState IO) Request
    -> GititServerPart [Char]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Request -> [Char]
    rqUri ServerPartT (ReaderT WikiState IO) Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
      Bool
    -> ServerPartT (ReaderT WikiState IO) ()
    -> ServerPartT (ReaderT WikiState IO) ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Bool -> Bool
    not ([Char] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    base') Bool -> Bool -> Bool
    && [Char]
    base' [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Char]
    uri')
        ServerPartT (ReaderT WikiState IO) ()
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero

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

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