{-# 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
  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 :: String
url = Request -> String
rqUri Request
rq String -> String -> String
forall a. [a] -> [a] -> [a]
++ Request -> String
rqQuery Request
rq
       case Maybe User
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
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
  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 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
  Config
cfg <- GititServerPart Config
getConfig
  Maybe User
mbUser <- case Maybe SessionData
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 -> (User -> String) -> Maybe User -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" User -> String
uUsername Maybe User
mbUser
  (Request -> Request) -> Handler -> Handler
forall a.
(Request -> Request)
-> ServerPartT (ReaderT WikiState IO) a
-> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (String -> String -> Request -> Request
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"REMOTE_USER" String
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 = do
  Request
req <- ServerPartT (ReaderT WikiState IO) Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  let user :: String
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
  (Request -> Request) -> Handler -> Handler
forall a.
(Request -> Request)
-> ServerPartT (ReaderT WikiState IO) a
-> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (String -> String -> Request -> Request
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"REMOTE_USER" String
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 String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ByteString -> String
UTF8.toString (String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"REMOTE_USER" Request
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
          Maybe User
mbUser <- String -> GititServerPart (Maybe User)
getUser String
u
          case Maybe User
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
_ <- String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Digest username=\""
  String
result' <- ParsecT String st Identity Char -> GenParser Char st String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"")
  Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
  String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
result'

pBasicHeader :: GenParser Char st String
pBasicHeader :: forall st. GenParser Char st String
pBasicHeader = do
  String
_ <- String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Basic "
  String
result' <- ParsecT String st Identity Char -> GenParser Char st String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
" \t\n")
  String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
UTF8.toString
         (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decodeLenient (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString String
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
  Config
cfg <- GititServerPart Config
getConfig
  String
page <- GititServerPart String
getPage
  if String
page String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [String]
noEdit Config
cfg
     then [String] -> Handler -> Handler
forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages (String
"Page is locked." String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Params -> [String]
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 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
  Config
cfg <- GititServerPart Config
getConfig
  String
page <- GititServerPart String
getPage
  if String
page String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [String]
noDelete Config
cfg
     then [String] -> Handler -> Handler
forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages (String
"Page cannot be deleted." String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Params -> [String]
pMessages Params
params) Handler
fallback
     else Handler
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
  Config
conf <- GititServerPart Config
getConfig
  String
path' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getPath
  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path'
     then String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> String
frontPage Config
conf)
     else if String -> Bool
isPage String
path'
             then String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path'
             else GititServerPart String
forall a. ServerPartT (ReaderT WikiState IO) a
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 :: forall (m :: * -> *). ServerMonad m => m String
getReferer = do
  Request
req <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  String
base' <- m String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"referer" Request
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
  String
path' <- m String
forall (m :: * -> *). ServerMonad m => m String
getPath
  String
uri' <- (Request -> String) -> m Request -> m String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Maybe String -> String
forall a. Partial => Maybe a -> a
fromJust (Maybe String -> String)
-> (Request -> Maybe String) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Maybe String
decString Bool
True (String -> Maybe String)
-> (Request -> String) -> Request -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
rqUri) m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  case String -> String -> Maybe String
calculateWikiBase String
path' String
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
  Config
cfg <- GititServerPart Config
getConfig
  Bool -> GititServerPart Bool
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> GititServerPart Bool) -> Bool -> GititServerPart Bool
forall a b. (a -> b) -> a -> b
$ String -> String
takeExtension String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Config -> String
defaultExtension Config
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
  Map String String
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
  String -> GititServerPart String
forall a. a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GititServerPart String)
-> String -> GititServerPart String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"application/octet-stream"
    (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
ext) Map String String
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
  String
base <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  String
uri' <- (Request -> String)
-> ServerPartT (ReaderT WikiState IO) Request
-> GititServerPart String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> String
rqUri ServerPartT (ReaderT WikiState IO) Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  let localpath :: String
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'
  Bool
-> ServerPartT (ReaderT WikiState IO) ()
-> ServerPartT (ReaderT WikiState IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
localpath Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& String -> String -> Char
forall a. Partial => String -> [a] -> a
lastNote String
"guardIndex" String
uri' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
    ServerPartT (ReaderT WikiState IO) ()
forall a. ServerPartT (ReaderT WikiState IO) a
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
  String
base' <- GititServerPart String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  String
uri' <- (Request -> String)
-> ServerPartT (ReaderT WikiState IO) Request
-> GititServerPart String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> String
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 (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base') Bool -> Bool -> Bool
&& String
base' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uri')
    ServerPartT (ReaderT WikiState IO) ()
forall a. ServerPartT (ReaderT WikiState IO) a
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 :: forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages [String]
messages m a
handler = do
  Request
req <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  let inps :: [(String, Input)]
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 -> (String, Input)
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 = [] }
                            })
  (Request -> Request) -> m a -> m a
forall a. (Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
rq -> Request
rq{ rqInputsQuery = map newInp messages ++ 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 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)