gitit-0.5.1: Gitit/Framework.hs
{-
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
-}
{- General framework for defining wiki actions.
-}
module Gitit.Framework (
Handler
, Recaptcha(..)
, Params(..)
, Command(..)
, getLoggedInUser
, sessionTime
, unlessNoEdit
, unlessNoDelete
, handle
, handlePage
, handleText
, handlePath
, withCommand
, uriPath
, isPage
, isDiscussPage
, isSourceCode
, urlForPage
, pathForPage
, withCommands
, getMimeTypeForExtension
, ifLoggedIn
, validate
)
where
import Gitit.Server
import Gitit.State
import Text.Pandoc.Shared (substitute)
import Control.Monad.Reader (mplus)
import Data.Char (toLower)
import Data.DateTime
import Control.Monad.Trans (MonadIO)
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Data.ByteString.UTF8 (fromString, toString)
import Data.Maybe (fromMaybe, fromJust)
import Data.List (intersect, intercalate, isSuffixOf)
import System.FilePath ((<.>), takeExtension)
import Codec.Binary.UTF8.String (decodeString, encodeString)
import Text.Highlighting.Kate
import Network.HTTP (urlEncode)
type Handler = ServerPart Response
data Recaptcha = Recaptcha {
recaptchaChallengeField :: String
, recaptchaResponseField :: String
} deriving (Read, Show)
data Params = Params { pUsername :: String
, pPassword :: String
, pPassword2 :: String
, pRevision :: Maybe String
, pDestination :: String
, pReferer :: Maybe String
, pUri :: String
, pForUser :: String
, pSince :: Maybe DateTime
, pRaw :: String
, pLimit :: Int
, pPatterns :: [String]
, pGotoPage :: String
, pEditedText :: Maybe String
, pMessages :: [String]
, pFrom :: Maybe String
, pTo :: Maybe String
, pFormat :: String
, pSHA1 :: String
, pLogMsg :: String
, pEmail :: String
, pFullName :: String
, pAccessCode :: String
, pWikiname :: String
, pPrintable :: Bool
, pOverwrite :: Bool
, pFilename :: String
, pFileContents :: B.ByteString
, pUser :: String
, pConfirm :: Bool
, pSessionKey :: Maybe SessionKey
, pRecaptcha :: Recaptcha
, pPeer :: String
} deriving Show
instance FromData Params where
fromData = do
un <- look "username" `mplus` return ""
pw <- look "password" `mplus` return ""
p2 <- look "password2" `mplus` return ""
rv <- (look "revision" >>= \s ->
return (if null s then Nothing else Just s)) `mplus` return Nothing
fu <- look "forUser" `mplus` return ""
si <- (look "since" >>= return . parseDateTime "%Y-%m-%d") `mplus` return Nothing -- YYYY-mm-dd format
ds <- (lookCookieValue "destination") `mplus` return "/"
ra <- look "raw" `mplus` return ""
lt <- look "limit" `mplus` return "100"
pa <- look "patterns" `mplus` return ""
gt <- look "gotopage" `mplus` return ""
me <- lookRead "messages" `mplus` return []
fm <- (look "from" >>= return . Just) `mplus` return Nothing
to <- (look "to" >>= return . Just) `mplus` return Nothing
et <- (look "editedText" >>= return . Just . filter (/= '\r')) `mplus` return Nothing
fo <- look "format" `mplus` return ""
sh <- look "sha1" `mplus` return ""
lm <- look "logMsg" `mplus` return ""
em <- look "email" `mplus` return ""
na <- look "fullname" `mplus` return ""
wn <- look "wikiname" `mplus` return ""
pr <- (look "printable" >> return True) `mplus` return False
ow <- (look "overwrite" >>= return . (== "yes")) `mplus` return False
fn <- (lookInput "file" >>= return . fromMaybe "" . inputFilename) `mplus` return ""
fc <- (lookInput "file" >>= return . inputValue) `mplus` return B.empty
ac <- look "accessCode" `mplus` return ""
cn <- (look "confirm" >> return True) `mplus` return False
sk <- (readCookieValue "sid" >>= return . Just) `mplus` return Nothing
rc <- look "recaptcha_challenge_field" `mplus` return ""
rr <- look "recaptcha_response_field" `mplus` return ""
return $ Params { pUsername = un
, pPassword = pw
, pPassword2 = p2
, pRevision = rv
, pForUser = fu
, pSince = si
, pDestination = ds
, pReferer = Nothing -- this gets set by handle...
, pUri = "" -- this gets set by handle...
, pRaw = ra
, pLimit = read lt
, pPatterns = words pa
, pGotoPage = gt
, pMessages = me
, pFrom = fm
, pTo = to
, pEditedText = et
, pFormat = fo
, pSHA1 = sh
, pLogMsg = lm
, pEmail = em
, pFullName = na
, pWikiname = wn
, pPrintable = pr
, pOverwrite = ow
, pFilename = fn
, pFileContents = fc
, pAccessCode = ac
, pUser = "" -- this gets set by ifLoggedIn...
, pConfirm = cn
, pSessionKey = sk
, pRecaptcha = Recaptcha { recaptchaChallengeField = rc, recaptchaResponseField = rr }
, pPeer = "" -- this gets set by handle...
}
data Command = Command (Maybe String)
instance FromData Command where
fromData = do
pairs <- lookPairs
return $ case map fst pairs `intersect` commandList of
[] -> Command Nothing
(c:_) -> Command $ Just c
where commandList = ["page", "request", "params", "edit", "showraw", "history",
"export", "diff", "cancel", "update", "delete", "discuss"]
getLoggedInUser :: MonadIO m => Params -> m (Maybe String)
getLoggedInUser params = do
mbSd <- maybe (return Nothing) getSession $ pSessionKey params
let user = case mbSd of
Nothing -> Nothing
Just sd -> Just $ sessionUser sd
return $! user
sessionTime :: Int
sessionTime = 60 * 60 -- session will expire 1 hour after page request
unlessNoEdit :: (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
unlessNoEdit responder fallback =
\page params -> do cfg <- getConfig
if page `elem` noEdit cfg
then fallback page params{pMessages = ("Page is locked." : pMessages params)}
else responder page params
unlessNoDelete :: (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
unlessNoDelete responder fallback =
\page params -> do cfg <- getConfig
if page `elem` noDelete cfg
then fallback page params{pMessages = ("Page cannot be deleted." : pMessages params)}
else responder page params
handle :: (String -> Bool) -> Method -> (String -> Params -> Web Response) -> Handler
handle pathtest meth responder = uriRest $ \uri ->
let path' = decodeString $ uriPath uri
in if pathtest path'
then withData $ \params ->
[ withRequest $ \req ->
if rqMethod req == meth
then do
let referer = case M.lookup (fromString "referer") (rqHeaders req) of
Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r
_ -> Nothing
let peer = fst $ rqPeer req
responder path' (params { pReferer = referer,
pUri = uri,
pPeer = peer })
else noHandle ]
else anyRequest noHandle
handlePage :: Method -> (String -> Params -> Web Response) -> Handler
handlePage = handle isPage
handleText :: Method -> (String -> Params -> Web Response) -> Handler
handleText = handle (\x -> isPage x || isSourceCode x)
handlePath :: String -> Method -> (String -> Params -> Web Response) -> Handler
handlePath path' = handle (== path')
withCommand :: String -> [Handler] -> Handler
withCommand command handlers =
withData $ \com -> case com of
Command (Just c) | c == command -> handlers
_ -> []
-- | 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 s = '.' `notElem` s
isDiscussPage :: String -> Bool
isDiscussPage s = isPage s && ":discuss" `isSuffixOf` s
isSourceCode :: String -> Bool
isSourceCode = not . null . languagesByExtension . takeExtension
urlForPage :: String -> String
urlForPage page = '/' : (substitute "%2f" "/" $ urlEncode $ encodeString page)
-- this is needed so that browsers recognize relative URLs correctly
pathForPage :: String -> FilePath
pathForPage page = page <.> "page"
withCommands :: Method -> [String] -> (String -> Request -> Web Response) -> Handler
withCommands meth commands page = withRequest $ \req -> do
if rqMethod req /= meth
then noHandle
else if all (`elem` (map fst $ rqInputs req)) commands
then page (intercalate "/" $ rqPaths req) req
else noHandle
getMimeTypeForExtension :: MonadIO m => String -> m String
getMimeTypeForExtension ext = do
mimes <- queryAppState mimeMap
return $ case M.lookup (dropWhile (=='.') $ map toLower ext) mimes of
Nothing -> "application/octet-stream"
Just t -> t
ifLoggedIn :: (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
-> (String -> Params -> Web Response)
ifLoggedIn responder fallback =
\page params -> do user <- getLoggedInUser params
case user of
Nothing -> do
fallback page (params { pReferer = Just $ pUri params })
Just u -> do
usrs <- queryAppState users
let e = case M.lookup u usrs of
Just usr -> uEmail usr
Nothing -> error $ "User '" ++ u ++ "' not found."
-- give the user another hour...
addCookie sessionTime (mkCookie "sid" (show $ fromJust $ pSessionKey params))
responder page (params { pUser = u, pEmail = e })
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