{-# 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.
-}moduleNetwork.Gitit.Framework(-- * Combinators for dealing with userswithUserFromSession,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)whereimportSafeimportNetwork.Gitit.ServerimportNetwork.Gitit.StateimportNetwork.Gitit.TypesimportData.FileStoreimportData.Char(toLower)importControl.Monad(mzero,liftM,unless,MonadPlus)importqualifiedData.MapasMimportqualifiedData.ByteString.UTF8asUTF8importqualifiedData.ByteString.Lazy.UTF8asLazyUTF8importData.Maybe(fromJust,fromMaybe)importData.List(intercalate,isPrefixOf,isInfixOf)importSystem.FilePath((<.>),takeExtension,takeFileName)importText.Highlighting.KateimportText.ParserCombinators.ParsecimportNetwork.URL(decString,encString)importNetwork.URI(isUnescapedInURI)importData.ByteString.Base64(decodeLenient)importNetwork.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->Handlerauthenticate=authenticateUserThat(constTrue)-- | Like 'authenticate', but with a predicate that the user must satisfy.authenticateUserThat::(User->Bool)->AuthenticationLevel->Handler->HandlerauthenticateUserThatpredicatelevelhandler=docfg<-getConfigiflevel<=requireAuthenticationcfgthendombUser<-getLoggedInUserrq<-askRqleturl=rqUrirq++rqQueryrqcasembUserofNothing->tempRedirect("/_login?"++urlEncodeVars[("destination",url)])$toResponse()Justu->ifpredicateuthenhandlerelseerror"Not authorized."elsehandler-- | Run the handler after setting @REMOTE_USER@ with the user from-- the session.withUserFromSession::Handler->HandlerwithUserFromSessionhandler=withData$\(sk::MaybeSessionKey)->dombSd<-maybe(returnNothing)getSessionskcfg<-getConfigmbUser<-casembSdofNothing->returnNothingJustsd->doaddCookie(MaxAge$sessionTimeoutcfg)(mkCookie"sid"(show$fromJustsk))-- refresh timeoutgetUser$!sessionUsersdletuser=maybe""uUsernamembUserlocalRq(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->HandlerwithUserFromHTTPAuthhandler=doreq<-askRqletuser=casegetHeader"authorization"reqofNothing->""JustauthHeader->caseparsepAuthorizationHeader""(UTF8.toStringauthHeader)ofLeft_->""Rightu->ulocalRq(setHeader"REMOTE_USER"user)handler-- | Returns @Just@ logged in user or @Nothing@.getLoggedInUser::GititServerPart(MaybeUser)getLoggedInUser=doreq<-askRqcasemaybe""UTF8.toString(getHeader"REMOTE_USER"req)of""->returnNothingu->dombUser<-getUserucasembUserofJustuser->return$JustuserNothing->return$JustUser{uUsername=u,uEmail="",uPassword=undefined}pAuthorizationHeader::GenParserCharstStringpAuthorizationHeader=trypBasicHeader<|>pDigestHeaderpDigestHeader::GenParserCharstStringpDigestHeader=do_<-string"Digest username=\""result'<-many(noneOf"\"")_<-char'"'returnresult'pBasicHeader::GenParserCharstStringpBasicHeader=do_<-string"Basic "result'<-many(noneOf" \t\n")return$takeWhile(/=':')$UTF8.toString$decodeLenient$UTF8.fromStringresult'-- | @unlessNoEdit responder fallback@ runs @responder@ unless the-- page has been designated not editable in configuration; in that-- case, runs @fallback@.unlessNoEdit::Handler->Handler->HandlerunlessNoEditresponderfallback=withData$\(params::Params)->docfg<-getConfigpage<-getPageifpage`elem`noEditcfgthenwithMessages("Page is locked.":pMessagesparams)fallbackelseresponder-- | @unlessNoDelete responder fallback@ runs @responder@ unless the-- page has been designated not deletable in configuration; in that-- case, runs @fallback@.unlessNoDelete::Handler->Handler->HandlerunlessNoDeleteresponderfallback=withData$\(params::Params)->docfg<-getConfigpage<-getPageifpage`elem`noDeletecfgthenwithMessages("Page cannot be deleted.":pMessagesparams)fallbackelseresponder-- | Returns the current path (subtracting initial commands like @\/_edit@).getPath::ServerMonadm=>mStringgetPath=liftM(intercalate"/".rqPaths)askRq-- | Returns the current page name (derived from the path).getPage::GititServerPartStringgetPage=doconf<-getConfigpath'<-getPathifnullpath'thenreturn(frontPageconf)elseifisPagepath'thenreturnpath'elsemzero-- fail if not valid page name-- | Returns the contents of the "referer" header.getReferer::ServerMonadm=>mStringgetReferer=doreq<-askRqbase'<-getWikiBasereturn$casegetHeader"referer"reqofJustr->caseUTF8.toStringrof""->base's->sNothing->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::ServerMonadm=>mStringgetWikiBase=dopath'<-getPathuri'<-liftM(fromJust.decStringTrue.rqUri)askRqcasecalculateWikiBasepath'uri'ofJustb->returnbNothing->error$"Could not getWikiBase: (path, uri) = "++show(path',uri')-- | The pure core of 'getWikiBase'.calculateWikiBase::String->String->MaybeStringcalculateWikiBasepath'uri'=letrevpaths=reverse.filter(not.null)$splitOn'/'path'revuris=reverse.filter(not.null)$splitOn'/'uri'inifrevpaths`isPrefixOf`revuristhenletrevbase=drop(lengthrevpaths)revuris-- a path like _feed is not part of the base...revbase'=caserevbaseof(x:xs)|startsWithUnderscorex->xsxs->xsbase'=intercalate"/"$reverserevbase'inJust$ifnullbase'then""else'/':base'elseNothingstartsWithUnderscore::String->BoolstartsWithUnderscore('_':_)=TruestartsWithUnderscore_=FalsesplitOn::Eqa=>a->[a]->[[a]]splitOnccs=let(next,rest)=break(==c)csincaserestof[]->[next](_:rs)->next:splitOncrs-- | Returns path portion of URI, without initial @\/@.-- Consecutive spaces are collapsed. We don't want to distinguish-- @Hi There@ and @Hi There@.uriPath::String->StringuriPath=unwords.words.drop1.takeWhile(/='?')isPage::String->BoolisPage""=FalseisPage('_':_)=FalseisPages=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->BoolisPageFilef=takeExtensionf==".page"isDiscussPage::String->BoolisDiscussPage('@':xs)=isPagexsisDiscussPage_=FalseisDiscussPageFile::FilePath->BoolisDiscussPageFile('@':xs)=isPageFilexsisDiscussPageFile_=FalseisSourceCode::String->BoolisSourceCodepath'=letlangs=languagesByFilename$takeFileNamepath'innot(nulllangs||takeExtensionpath'==".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->StringurlForPagepage='/':encStringFalseisUnescapedInURIpage-- | Returns the filestore path of the file containing the page's source.pathForPage::String->FilePathpathForPagepage=page<.>"page"-- | Retrieves a mime type based on file extension.getMimeTypeForExtension::String->GititServerPartStringgetMimeTypeForExtensionext=domimes<-liftMmimeMapgetConfigreturn$fromMaybe"application/octet-stream"(M.lookup(dropWhile(=='.')$maptoLowerext)mimes)-- | Simple helper for validation of forms.validate::[(Bool,String)]-- ^ list of conditions and error messages->[String]-- ^ list of error messagesvalidate=foldlgo[]wheregoerrs(condition,msg)=ifconditionthenmsg:errselseerrsguardCommand::String->GititServerPart()guardCommandcommand=withData$\(com::Command)->casecomofCommand(Justc)|c==command->return()_->mzeroguardPath::(String->Bool)->GititServerPart()guardPathpred'=guardRq(pred'.rqUri)-- | Succeeds if path is an index path: e.g. @\/foo\/bar/@.guardIndex::GititServerPart()guardIndex=dobase<-getWikiBaseuri'<-liftMrqUriaskRqletlocalpath=drop(lengthbase)uri'unless(lengthlocalpath>1&&lastNote"guardIndex"uri'=='/')mzero-- Guard against a path like @\/wiki@ when the wiki is being-- served at @\/wiki@.guardBareBase::GititServerPart()guardBareBase=dobase'<-getWikiBaseuri'<-liftMrqUriaskRqunless(not(nullbase')&&base'==uri')mzero-- | Runs a server monad in a local context after setting-- the "messages" request header.withMessages::ServerMonadm=>[String]->ma->mawithMessagesmessageshandler=doreq<-askRqletinps=filter(\(n,_)->n/="messages")$rqInputsQueryreqletnewInp=("messages",Input{inputValue=Right$LazyUTF8.fromString$showmessages,inputFilename=Nothing,inputContentType=ContentType{ctType="text",ctSubtype="plain",ctParameters=[]}})localRq(\rq->rq{rqInputsQuery=newInp:inps})handler-- | Returns a filestore object derived from the-- repository path and filestore type specified in configuration.filestoreFromConfig::Config->FileStorefilestoreFromConfigconf=caserepositoryTypeconfofGit->gitFileStore$repositoryPathconfDarcs->darcsFileStore$repositoryPathconfMercurial->mercurialFileStore$repositoryPathconf