Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

349 lines (313 sloc) 13.76 kB
{-# 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
, 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, MonadPlus)
import qualified Data.Map as M
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8
import Data.Maybe (fromJust, fromMaybe)
import Data.List (intercalate, isPrefixOf, isInfixOf)
import System.FilePath ((<.>), takeExtension, takeFileName)
import Text.Highlighting.Kate
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 = authenticateUserThat (const True)
-- | Like 'authenticate', but with a predicate that the user must satisfy.
authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
authenticateUserThat predicate level handler = do
cfg <- getConfig
if level <= requireAuthentication cfg
then do
mbUser <- getLoggedInUser
rq <- askRq
let url = rqUri rq ++ rqQuery rq
case mbUser of
Nothing -> tempRedirect ("/_login?" ++ urlEncodeVars [("destination", url)]) $ toResponse ()
Just u -> if predicate u
then handler
else error "Not authorized."
else handler
-- | Run the handler after setting @REMOTE_USER@ with the user from
-- the session.
withUserFromSession :: Handler -> Handler
withUserFromSession handler = withData $ \(sk :: Maybe SessionKey) -> do
mbSd <- maybe (return Nothing) getSession sk
cfg <- getConfig
mbUser <- case mbSd of
Nothing -> return Nothing
Just sd -> do
addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show $ fromJust sk)) -- refresh timeout
getUser $! sessionUser sd
let user = maybe "" uUsername 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 = do
req <- askRq
let user = case getHeader "authorization" req of
Nothing -> ""
Just authHeader -> case parse pAuthorizationHeader "" (UTF8.toString authHeader) of
Left _ -> ""
Right u -> u
localRq (setHeader "REMOTE_USER" user) handler
-- | Returns @Just@ logged in user or @Nothing@.
getLoggedInUser :: GititServerPart (Maybe User)
getLoggedInUser = do
req <- askRq
case maybe "" UTF8.toString (getHeader "REMOTE_USER" req) of
"" -> return Nothing
u -> do
mbUser <- getUser u
case mbUser of
Just user -> return $ Just user
Nothing -> return $ Just User{uUsername = u, uEmail = "", uPassword = undefined}
pAuthorizationHeader :: GenParser Char st String
pAuthorizationHeader = try pBasicHeader <|> pDigestHeader
pDigestHeader :: GenParser Char st String
pDigestHeader = do
_ <- string "Digest username=\""
result' <- many (noneOf "\"")
_ <- char '"'
return result'
pBasicHeader :: GenParser Char st String
pBasicHeader = do
_ <- 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 responder fallback = withData $ \(params :: Params) -> do
cfg <- 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 responder fallback = withData $ \(params :: Params) -> do
cfg <- 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 = liftM (intercalate "/" . rqPaths) askRq
-- | Returns the current page name (derived from the path).
getPage :: GititServerPart String
getPage = do
conf <- 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 = do
req <- askRq
base' <- getWikiBase
return $ case getHeader "referer" req of
Just r -> case UTF8.toString r of
"" -> base'
s -> s
Nothing -> 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 = do
path' <- getPath
uri' <- liftM (fromJust . decString True . rqUri) askRq
case calculateWikiBase path' uri' of
Just b -> return b
Nothing -> error $ "Could not getWikiBase: (path, uri) = " ++ show (path',uri')
-- | The pure core of 'getWikiBase'.
calculateWikiBase :: String -> String -> Maybe String
calculateWikiBase path' uri' =
let revpaths = reverse . filter (not . null) $ splitOn '/' path'
revuris = reverse . filter (not . null) $ splitOn '/' uri'
in if revpaths `isPrefixOf` revuris
then let revbase = drop (length revpaths) revuris
-- a path like _feed is not part of the base...
revbase' = case revbase of
(x:xs) | startsWithUnderscore x -> xs
xs -> xs
base' = intercalate "/" $ reverse revbase'
in Just $ if null base' then "" else '/' : base'
else Nothing
startsWithUnderscore :: String -> Bool
startsWithUnderscore ('_':_) = True
startsWithUnderscore _ = False
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn c cs =
let (next, rest) = break (==c) cs
in case rest of
[] -> [next]
(_:rs) -> next : splitOn c 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 = unwords . words . drop 1 . takeWhile (/='?')
isPage :: String -> Bool
isPage "" = False
isPage ('_':_) = False
isPage s = all (`notElem` "*?") s && not (".." `isInfixOf` s) && not ("/_" `isInfixOf` 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 -> Bool
isPageFile f = takeExtension f == ".page"
isDiscussPage :: String -> Bool
isDiscussPage ('@':xs) = isPage xs
isDiscussPage _ = False
isDiscussPageFile :: FilePath -> Bool
isDiscussPageFile ('@':xs) = isPageFile xs
isDiscussPageFile _ = False
isSourceCode :: String -> Bool
isSourceCode path' =
let langs = languagesByFilename $ takeFileName path'
in not (null langs || takeExtension path' == ".svg")
-- allow svg 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 page = '/' : encString False isUnescapedInURI page
-- | Returns the filestore path of the file containing the page's source.
pathForPage :: String -> FilePath
pathForPage page = page <.> "page"
-- | Retrieves a mime type based on file extension.
getMimeTypeForExtension :: String -> GititServerPart String
getMimeTypeForExtension ext = do
mimes <- liftM mimeMap 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 = foldl go []
where go errs (condition, msg) = if condition then msg:errs else errs
guardCommand :: String -> GititServerPart ()
guardCommand command = withData $ \(com :: Command) ->
case com of
Command (Just c) | c == command -> return ()
_ -> mzero
guardPath :: (String -> Bool) -> GititServerPart ()
guardPath pred' = guardRq (pred' . rqUri)
-- | Succeeds if path is an index path: e.g. @\/foo\/bar/@.
guardIndex :: GititServerPart ()
guardIndex = do
base <- getWikiBase
uri' <- liftM rqUri askRq
let localpath = drop (length base) 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 = do
base' <- 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 messages handler = do
req <- askRq
let inps = filter (\(n,_) -> n /= "message") $ rqInputsQuery req
let newInp msg = ("message", Input {
inputValue = Right
$ LazyUTF8.fromString msg
, inputFilename = Nothing
, inputContentType = ContentType {
ctType = "text"
, ctSubtype = "plain"
, ctParameters = [] }
})
localRq (\rq -> 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 conf =
case repositoryType conf of
Git -> gitFileStore $ repositoryPath conf
Darcs -> darcsFileStore $ repositoryPath conf
Mercurial -> mercurialFileStore $ repositoryPath conf
Jump to Line
Something went wrong with that request. Please try again.