diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,11 @@ +Version 0.12 released 19 Aug 2015 + + * Export all modules. + * Make executable builds depend on the library in cabal file. + * Moved library files to src directory. + * Added stack.yaml. + * Updated README with stack install instructions. + Version 0.11.1.1 released 14 Aug 2015 * Fixed Network.Gitit.Initialize so it compiles with older pandoc (#506). diff --git a/Network/Gitit.hs b/Network/Gitit.hs deleted file mode 100644 --- a/Network/Gitit.hs +++ /dev/null @@ -1,224 +0,0 @@ -{- -Copyright (C) 2009 John MacFarlane - -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 --} - -{- | Functions for embedding a gitit wiki into a Happstack application. - -The following is a minimal standalone wiki program: - -> import Network.Gitit -> import Happstack.Server.SimpleHTTP -> -> main = do -> conf <- getDefaultConfig -> createStaticIfMissing conf -> createTemplateIfMissing conf -> createRepoIfMissing conf -> initializeGititState conf -> simpleHTTP nullConf{port = 5001} $ wiki conf - -Here is a more complex example, which serves different wikis -under different paths, and uses a custom authentication scheme: - -> import Network.Gitit -> import Control.Monad -> import Text.XHtml hiding (dir) -> import Happstack.Server.SimpleHTTP -> -> type WikiSpec = (String, FileStoreType, PageType) -> -> wikis = [ ("markdownWiki", Git, Markdown) -> , ("latexWiki", Darcs, LaTeX) ] -> -> -- custom authentication -> myWithUser :: Handler -> Handler -> myWithUser handler = do -> -- replace the following with a function that retrieves -> -- the logged in user for your happstack app: -> user <- return "testuser" -> localRq (setHeader "REMOTE_USER" user) handler -> -> myAuthHandler = msum -> [ dir "_login" $ seeOther "/your/login/url" $ toResponse () -> , dir "_logout" $ seeOther "/your/logout/url" $ toResponse () ] -> -> handlerFor :: Config -> WikiSpec -> ServerPart Response -> handlerFor conf (path', fstype, pagetype) = dir path' $ -> wiki conf{ repositoryPath = path' -> , repositoryType = fstype -> , defaultPageType = pagetype} -> -> indexPage :: ServerPart Response -> indexPage = ok $ toResponse $ -> (p << "Wiki index") +++ -> ulist << map (\(path', _, _) -> li << hotlink (path' ++ "/") << path') wikis -> -> main = do -> conf <- getDefaultConfig -> let conf' = conf{authHandler = myAuthHandler, withUser = myWithUser} -> forM wikis $ \(path', fstype, pagetype) -> do -> let conf'' = conf'{ repositoryPath = path' -> , repositoryType = fstype -> , defaultPageType = pagetype -> } -> createStaticIfMissing conf'' -> createRepoIfMissing conf'' -> createTemplateIfMissing conf' -> initializeGititState conf' -> simpleHTTP nullConf{port = 5001} $ -> (nullDir >> indexPage) `mplus` msum (map (handlerFor conf') wikis) - --} - -module Network.Gitit ( - -- * Wiki handlers - wiki - , reloadTemplates - , runHandler - -- * Initialization - , module Network.Gitit.Initialize - -- * Configuration - , module Network.Gitit.Config - , loginUserForm - -- * Types - , module Network.Gitit.Types - -- * Tools for building handlers - , module Network.Gitit.Framework - , module Network.Gitit.Layout - , module Network.Gitit.ContentTransformer - , module Network.Gitit.Page - , getFileStore - , getUser - , getConfig - , queryGititState - , updateGititState - ) -where -import Network.Gitit.Types -import Network.Gitit.Server -import Network.Gitit.Framework -import Network.Gitit.Handlers -import Network.Gitit.Initialize -import Network.Gitit.Config -import Network.Gitit.Layout -import Network.Gitit.State - (getFileStore, getUser, getConfig, queryGititState, updateGititState) -import Network.Gitit.ContentTransformer -import Network.Gitit.Page -import Network.Gitit.Authentication (loginUserForm) -import Paths_gitit (getDataFileName) -import Control.Monad.Reader -import Prelude hiding (readFile) -import qualified Data.ByteString.Char8 as B -import System.FilePath (()) -import System.Directory (getTemporaryDirectory) -import Safe - --- | Happstack handler for a gitit wiki. -wiki :: Config -> ServerPart Response -wiki conf = do - tempDir <- liftIO getTemporaryDirectory - let maxSize = fromIntegral $ maxUploadSize conf - decodeBody $ defaultBodyPolicy tempDir maxSize maxSize maxSize - let static = staticDir conf - defaultStatic <- liftIO $ getDataFileName $ "data" "static" - -- if file not found in staticDir, we check also in the data/static - -- directory, which contains defaults - let staticHandler = withExpiresHeaders $ - serveDirectory' static `mplus` serveDirectory' defaultStatic - let debugHandler' = msum [debugHandler | debugMode conf] - let handlers = debugHandler' `mplus` authHandler conf `mplus` - authenticate ForRead (msum wikiHandlers) - let fs = filestoreFromConfig conf - let ws = WikiState { wikiConfig = conf, wikiFileStore = fs } - if compressResponses conf - then compressedResponseFilter - else return "" - staticHandler `mplus` runHandler ws (withUser conf handlers) - --- | Like 'serveDirectory', but if file is not found, fail instead of --- returning a 404 error. -serveDirectory' :: FilePath -> ServerPart Response -serveDirectory' p = do - rq <- askRq - resp' <- serveDirectory EnableBrowsing [] p - if rsCode resp' == 404 || lastNote "fileServeStrict'" (rqUri rq) == '/' - then mzero -- pass through if not found or directory index - else - -- turn off compresion filter unless it's text - case getHeader "Content-Type" resp' of - Just ct | B.pack "text/" `B.isPrefixOf` ct -> return resp' - _ -> ignoreFilters >> return resp' - -wikiHandlers :: [Handler] -wikiHandlers = - [ -- redirect /wiki -> /wiki/ when gitit is being served at /wiki - -- so that relative wikilinks on the page will work properly: - guardBareBase >> getWikiBase >>= \b -> movedPermanently (b ++ "/") (toResponse ()) - , dir "_activity" showActivity - , dir "_go" goToPage - , method GET >> dir "_search" searchResults - , dir "_upload" $ do guard =<< return . uploadsAllowed =<< getConfig - msum [ method GET >> authenticate ForModify uploadForm - , method POST >> authenticate ForModify uploadFile ] - , dir "_random" $ method GET >> randomPage - , dir "_index" indexPage - , dir "_feed" feedHandler - , dir "_category" categoryPage - , dir "_categories" categoryListPage - , dir "_expire" expireCache - , dir "_showraw" $ msum - [ showRawPage - , guardPath isSourceCode >> showFileAsText ] - , dir "_history" $ msum - [ showPageHistory - , guardPath isSourceCode >> showFileHistory ] - , dir "_edit" $ authenticate ForModify (unlessNoEdit editPage showPage) - , dir "_diff" $ msum - [ showPageDiff - , guardPath isSourceCode >> showFileDiff ] - , dir "_discuss" discussPage - , dir "_delete" $ msum - [ method GET >> - authenticate ForModify (unlessNoDelete confirmDelete showPage) - , method POST >> - authenticate ForModify (unlessNoDelete deletePage showPage) ] - , dir "_preview" preview - , guardIndex >> indexPage - , guardCommand "export" >> exportPage - , method POST >> guardCommand "cancel" >> showPage - , method POST >> guardCommand "update" >> - authenticate ForModify (unlessNoEdit updatePage showPage) - , showPage - , guardPath isSourceCode >> method GET >> showHighlightedSource - , handleAny - , notFound =<< (guardPath isPage >> createPage) - ] - --- | Recompiles the gitit templates. -reloadTemplates :: ServerPart Response -reloadTemplates = do - liftIO recompilePageTemplate - ok $ toResponse "Page templates have been recompiled." - --- | Converts a gitit Handler into a standard happstack ServerPart. -runHandler :: WikiState -> Handler -> ServerPart Response -runHandler = mapServerPartT . unpackReaderT - -unpackReaderT :: s -> UnWebT (ReaderT s IO) a -> UnWebT IO a -unpackReaderT st uw = runReaderT uw st - diff --git a/Network/Gitit/Authentication.hs b/Network/Gitit/Authentication.hs deleted file mode 100644 --- a/Network/Gitit/Authentication.hs +++ /dev/null @@ -1,541 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} -{- -Copyright (C) 2009 John MacFarlane , - Henry Laxen - -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 --} - -{- Handlers for registering and authenticating users. --} - -module Network.Gitit.Authentication ( loginUserForm - , formAuthHandlers - , httpAuthHandlers - , rpxAuthHandlers - , githubAuthHandlers) where - -import Network.Gitit.State -import Network.Gitit.Types -import Network.Gitit.Framework -import Network.Gitit.Layout -import Network.Gitit.Server -import Network.Gitit.Util -import Network.Gitit.Authentication.Github -import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) -import Text.XHtml hiding ( (), dir, method, password, rev ) -import qualified Text.XHtml as X ( password ) -import System.Process (readProcessWithExitCode) -import Control.Monad (unless, liftM, mplus) -import Control.Monad.Trans (liftIO) -import System.Exit -import System.Log.Logger (logM, Priority(..)) -import Data.Char (isAlphaNum, isAlpha) -import qualified Data.Map as M -import Text.Pandoc.Shared (substitute) -import Data.Maybe (isJust, fromJust, isNothing, fromMaybe) -import Network.URL (exportURL, add_param, importURL) -import Network.BSD (getHostName) -import qualified Text.StringTemplate as T -import Network.HTTP (urlEncodeVars, urlDecode, urlEncode) -import Codec.Binary.UTF8.String (encodeString) -import Data.ByteString.UTF8 (toString) -import Network.Gitit.Rpxnow as R - -data ValidationType = Register - | ResetPassword - deriving (Show,Read) - -registerUser :: Params -> Handler -registerUser params = do - result' <- sharedValidation Register params - case result' of - Left errors -> registerForm >>= - formattedPage defaultPageLayout{ - pgMessages = errors, - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Register for an account" - } - Right (uname, email, pword) -> do - user <- liftIO $ mkUser uname email pword - addUser uname user - loginUser params{ pUsername = uname, - pPassword = pword, - pEmail = email } - -resetPasswordRequestForm :: Params -> Handler -resetPasswordRequestForm _ = do - let passwordForm = gui "" ! [identifier "resetPassword"] << fieldset << - [ label ! [thefor "username"] << "Username: " - , textfield "username" ! [size "20", intAttr "tabindex" 1], stringToHtml " " - , submit "resetPassword" "Reset Password" ! [intAttr "tabindex" 2]] - cfg <- getConfig - let contents = if null (mailCommand cfg) - then p << "Sorry, password reset not available." - else passwordForm - formattedPage defaultPageLayout{ - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Reset your password" } - contents - -resetPasswordRequest :: Params -> Handler -resetPasswordRequest params = do - let uname = pUsername params - mbUser <- getUser uname - let errors = case mbUser of - Nothing -> ["Unknown user. Please re-register " ++ - "or press the Back button to try again."] - Just u -> ["Since you did not register with " ++ - "an email address, we can't reset your password." | - null (uEmail u) ] - if null errors - then do - let response = - p << [ stringToHtml "An email has been sent to " - , bold $ stringToHtml . uEmail $ fromJust mbUser - , br - , stringToHtml - "Please click on the enclosed link to reset your password." - ] - sendReregisterEmail (fromJust mbUser) - formattedPage defaultPageLayout{ - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Resetting your password" - } - response - else registerForm >>= - formattedPage defaultPageLayout{ - pgMessages = errors, - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Register for an account" - } - -resetLink :: String -> User -> String -resetLink base' user = - exportURL $ foldl add_param - (fromJust . importURL $ base' ++ "/_doResetPassword") - [("username", uUsername user), ("reset_code", take 20 (pHashed (uPassword user)))] - -sendReregisterEmail :: User -> GititServerPart () -sendReregisterEmail user = do - cfg <- getConfig - hostname <- liftIO getHostName - base' <- getWikiBase - let messageTemplate = T.newSTMP $ resetPasswordMessage cfg - let filledTemplate = T.render . - T.setAttribute "username" (uUsername user) . - T.setAttribute "useremail" (uEmail user) . - T.setAttribute "hostname" hostname . - T.setAttribute "port" (show $ portNumber cfg) . - T.setAttribute "resetlink" (resetLink base' user) $ - messageTemplate - let (mailcommand:args) = words $ substitute "%s" (uEmail user) - (mailCommand cfg) - (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args - filledTemplate - liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user ++ - " at " ++ uEmail user - unless (exitCode == ExitSuccess) $ - liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ pErr - -validateReset :: Params -> (User -> Handler) -> Handler -validateReset params postValidate = do - let uname = pUsername params - user <- getUser uname - let knownUser = isJust user - let resetCodeMatches = take 20 (pHashed (uPassword (fromJust user))) == - pResetCode params - let errors = case (knownUser, resetCodeMatches) of - (True, True) -> [] - (True, False) -> ["Your reset code is invalid"] - (False, _) -> ["User " ++ - renderHtmlFragment (stringToHtml uname) ++ - " is not known"] - if null errors - then postValidate (fromJust user) - else registerForm >>= - formattedPage defaultPageLayout{ - pgMessages = errors, - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Register for an account" - } - -resetPassword :: Params -> Handler -resetPassword params = validateReset params $ \user -> - resetPasswordForm (Just user) >>= - formattedPage defaultPageLayout{ - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Reset your registration info" - } - -doResetPassword :: Params -> Handler -doResetPassword params = validateReset params $ \user -> do - result' <- sharedValidation ResetPassword params - case result' of - Left errors -> - resetPasswordForm (Just user) >>= - formattedPage defaultPageLayout{ - pgMessages = errors, - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Reset your registration info" - } - Right (uname, email, pword) -> do - user' <- liftIO $ mkUser uname email pword - adjustUser uname user' - liftIO $ logM "gitit" WARNING $ - "Successfully reset password and email for " ++ uUsername user' - loginUser params{ pUsername = uname, - pPassword = pword, - pEmail = email } - -registerForm :: GititServerPart Html -registerForm = sharedForm Nothing - -resetPasswordForm :: Maybe User -> GititServerPart Html -resetPasswordForm = sharedForm -- synonym for now - -sharedForm :: Maybe User -> GititServerPart Html -sharedForm mbUser = withData $ \params -> do - cfg <- getConfig - dest <- case pDestination params of - "" -> getReferer - x -> return x - let accessQ = case mbUser of - Just _ -> noHtml - Nothing -> case accessQuestion cfg of - Nothing -> noHtml - Just (prompt, _) -> label ! [thefor "accessCode"] << prompt +++ br +++ - X.password "accessCode" ! [size "15", intAttr "tabindex" 1] - +++ br - let captcha = if useRecaptcha cfg - then captchaFields (recaptchaPublicKey cfg) Nothing - else noHtml - let initField field = case mbUser of - Nothing -> "" - Just user -> field user - let userNameField = case mbUser of - Nothing -> label ! [thefor "username"] << - "Username (at least 3 letters or digits):" - +++ br +++ - textfield "username" ! [size "20", intAttr "tabindex" 2] +++ br - Just user -> label ! [thefor "username"] << - ("Username (cannot be changed): " ++ uUsername user) - +++ br - let submitField = case mbUser of - Nothing -> submit "register" "Register" - Just _ -> submit "resetPassword" "Reset Password" - - return $ gui "" ! [identifier "loginForm"] << fieldset << - [ accessQ - , userNameField - , label ! [thefor "email"] << "Email (optional, will not be displayed on the Wiki):" - , br - , textfield "email" ! [size "20", intAttr "tabindex" 3, value (initField uEmail)] - , br ! [theclass "req"] - , textfield "full_name_1" ! [size "20", theclass "req"] - , br - , label ! [thefor "password"] - << ("Password (at least 6 characters," ++ - " including at least one non-letter):") - , br - , X.password "password" ! [size "20", intAttr "tabindex" 4] - , stringToHtml " " - , br - , label ! [thefor "password2"] << "Confirm Password:" - , br - , X.password "password2" ! [size "20", intAttr "tabindex" 5] - , stringToHtml " " - , br - , captcha - , textfield "destination" ! [thestyle "display: none;", value dest] - , submitField ! [intAttr "tabindex" 6]] - - -sharedValidation :: ValidationType - -> Params - -> GititServerPart (Either [String] (String,String,String)) -sharedValidation validationType params = do - let isValidUsernameChar c = isAlphaNum c || c == ' ' - let isValidUsername u = length u >= 3 && all isValidUsernameChar u - let isValidPassword pw = length pw >= 6 && not (all isAlpha pw) - let accessCode = pAccessCode params - let uname = pUsername params - let pword = pPassword params - let pword2 = pPassword2 params - let email = pEmail params - let fakeField = pFullName params - let recaptcha = pRecaptcha params - taken <- isUser uname - cfg <- getConfig - let optionalTests Register = - [(taken, "Sorry, that username is already taken.")] - optionalTests ResetPassword = [] - let isValidAccessCode = case validationType of - ResetPassword -> True - Register -> case accessQuestion cfg of - Nothing -> True - Just (_, answers) -> accessCode `elem` answers - let isValidEmail e = length (filter (=='@') e) == 1 - peer <- liftM (fst . rqPeer) askRq - captchaResult <- - if useRecaptcha cfg - then if null (recaptchaChallengeField recaptcha) || - null (recaptchaResponseField recaptcha) - -- no need to bother captcha.net in this case - then return $ Left "missing-challenge-or-response" - else liftIO $ do - mbIPaddr <- lookupIPAddr peer - let ipaddr = fromMaybe (error $ "Could not find ip address for " ++ peer) - mbIPaddr - ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg) - ipaddr (recaptchaChallengeField recaptcha) - (recaptchaResponseField recaptcha) - else return $ Right () - let (validCaptcha, captchaError) = - case captchaResult of - Right () -> (True, Nothing) - Left err -> (False, Just err) - let errors = validate $ optionalTests validationType ++ - [ (not isValidAccessCode, "Incorrect response to access prompt.") - , (not (isValidUsername uname), - "Username must be at least 3 charcaters, all letters or digits.") - , (not (isValidPassword pword), - "Password must be at least 6 characters, " ++ - "and must contain at least one non-letter.") - , (not (null email) && not (isValidEmail email), - "Email address appears invalid.") - , (pword /= pword2, - "Password does not match confirmation.") - , (not validCaptcha, - "Failed CAPTCHA (" ++ fromJust captchaError ++ - "). Are you really human?") - , (not (null fakeField), -- fakeField is hidden in CSS (honeypot) - "You do not seem human enough. If you're sure you are human, " ++ - "try turning off form auto-completion in your browser.") - ] - return $ if null errors then Right (uname, email, pword) else Left errors - --- user authentication -loginForm :: String -> GititServerPart Html -loginForm dest = do - cfg <- getConfig - base' <- getWikiBase - return $ gui (base' ++ "/_login") ! [identifier "loginForm"] << - fieldset << - [ label ! [thefor "username"] << "Username " - , textfield "username" ! [size "15", intAttr "tabindex" 1] - , stringToHtml " " - , label ! [thefor "password"] << "Password " - , X.password "password" ! [size "15", intAttr "tabindex" 2] - , stringToHtml " " - , textfield "destination" ! [thestyle "display: none;", value dest] - , submit "login" "Login" ! [intAttr "tabindex" 3] - ] +++ - p << [ stringToHtml "If you do not have an account, " - , anchor ! [href $ base' ++ "/_register?" ++ - urlEncodeVars [("destination", encodeString dest)]] << "click here to get one." - ] +++ - if null (mailCommand cfg) - then noHtml - else p << [ stringToHtml "If you forgot your password, " - , anchor ! [href $ base' ++ "/_resetPassword"] << - "click here to get a new one." - ] - -loginUserForm :: Handler -loginUserForm = withData $ \params -> do - dest <- case pDestination params of - "" -> getReferer - x -> return x - loginForm dest >>= - formattedPage defaultPageLayout{ pgShowPageTools = False, - pgTabs = [], - pgTitle = "Login", - pgMessages = pMessages params - } - -loginUser :: Params -> Handler -loginUser params = do - let uname = pUsername params - let pword = pPassword params - let destination = pDestination params - allowed <- authUser uname pword - cfg <- getConfig - if allowed - then do - key <- newSession (sessionData uname) - addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) - seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ - renderHtmlFragment (stringToHtml uname)) - else - withMessages ["Invalid username or password."] loginUserForm - -logoutUser :: Params -> Handler -logoutUser params = do - let key = pSessionKey params - dest <- case pDestination params of - "" -> getReferer - x -> return x - case key of - Just k -> do - delSession k - expireCookie "sid" - Nothing -> return () - seeOther (encUrl dest) $ toResponse "You have been logged out." - -registerUserForm :: Handler -registerUserForm = registerForm >>= - formattedPage defaultPageLayout{ - pgShowPageTools = False, - pgTabs = [], - pgTitle = "Register for an account" - } - -formAuthHandlers :: [Handler] -formAuthHandlers = - [ dir "_register" $ method GET >> registerUserForm - , dir "_register" $ method POST >> withData registerUser - , dir "_login" $ method GET >> loginUserForm - , dir "_login" $ method POST >> withData loginUser - , dir "_logout" $ method GET >> withData logoutUser - , dir "_resetPassword" $ method GET >> withData resetPasswordRequestForm - , dir "_resetPassword" $ method POST >> withData resetPasswordRequest - , dir "_doResetPassword" $ method GET >> withData resetPassword - , dir "_doResetPassword" $ method POST >> withData doResetPassword - , dir "_user" currentUser - ] - -loginUserHTTP :: Params -> Handler -loginUserHTTP params = do - base' <- getWikiBase - let destination = pDestination params `orIfNull` (base' ++ "/") - seeOther (encUrl destination) $ toResponse () - -logoutUserHTTP :: Handler -logoutUserHTTP = unauthorized $ toResponse () -- will this work? - -httpAuthHandlers :: [Handler] -httpAuthHandlers = - [ dir "_logout" logoutUserHTTP - , dir "_login" $ withData loginUserHTTP - , dir "_user" currentUser ] - -oauthGithubCallback :: GithubConfig - -> GithubCallbackPars -- ^ Authentication code gained after authorization - -> Handler -oauthGithubCallback ghConfig githubCallbackPars = - withData $ \(sk :: Maybe SessionKey) -> - do - mbSd <- maybe (return Nothing) getSession sk - mbGititState <- case mbSd of - Nothing -> return Nothing - Just sd -> return $ sessionGithubState sd - let gititState = fromMaybe (error "No Github state found in session (is it the same domain?)") mbGititState - mUser <- getGithubUser ghConfig githubCallbackPars gititState - base' <- getWikiBase - let destination = base' ++ "/" - case mUser of - Right user -> do - let userEmail = uEmail user - updateGititState $ \s -> s { users = M.insert userEmail user (users s) } - addUser (uUsername user) user - key <- newSession (sessionData userEmail) - cfg <- getConfig - addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) - seeOther (encUrl destination) $ toResponse () - Left err -> do - liftIO $ logM "gitit" WARNING $ "Login Failed: " ++ ghUserMessage err ++ maybe "" (". Github response" ++) (ghDetails err) - let url = destination ++ "?message=" ++ ghUserMessage err - seeOther (encUrl url) $ toResponse () - -githubAuthHandlers :: GithubConfig - -> [Handler] -githubAuthHandlers ghConfig = - [ dir "_logout" $ withData logoutUser - , dir "_login" $ loginGithubUser $ oAuth2 ghConfig - , dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig - , dir "_user" currentUser ] - --- Login using RPX (see RPX development docs at https://rpxnow.com/docs) -loginRPXUser :: RPars -- ^ The parameters passed by the RPX callback call (after authentication has taken place - -> Handler -loginRPXUser params = do - cfg <- getConfig - ref <- getReferer - let mtoken = rToken params - if isNothing mtoken - then do - let url = baseUrl cfg ++ "/_login?destination=" ++ - fromMaybe ref (rDestination params) - if null (rpxDomain cfg) - then error "rpx-domain is not set." - else do - let rpx = "https://" ++ rpxDomain cfg ++ - ".rpxnow.com/openid/v2/signin?token_url=" ++ - urlEncode url - see rpx - else do -- We got an answer from RPX, this might also return an exception. - uid' :: Either String R.Identifier <- liftIO $ - R.authenticate (rpxKey cfg) $ fromJust mtoken - uid <- case uid' of - Right u -> return u - Left err -> error err - liftIO $ logM "gitit.loginRPXUser" DEBUG $ "uid:" ++ show uid - -- We need to get an unique identifier for the user - -- The 'identifier' is always present but can be rather cryptic - -- The 'verifiedEmail' is also unique and is a more readable choice - -- so we use it if present. - let userId = R.userIdentifier uid - let email = prop "verifiedEmail" uid - user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none" - updateGititState $ \s -> s { users = M.insert userId user (users s) } - key <- newSession (sessionData userId) - addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) - see $ fromJust $ rDestination params - where - prop pname info = lookup pname $ R.userData info - see url = seeOther (encUrl url) $ toResponse noHtml - --- The parameters passed by the RPX callback call. -data RPars = RPars { rToken :: Maybe String - , rDestination :: Maybe String } - deriving Show - -instance FromData RPars where - fromData = do - vtoken <- liftM Just (look "token") `mplus` return Nothing - vDestination <- liftM (Just . urlDecode) (look "destination") `mplus` - return Nothing - return RPars { rToken = vtoken - , rDestination = vDestination } - -rpxAuthHandlers :: [Handler] -rpxAuthHandlers = - [ dir "_logout" $ method GET >> withData logoutUser - , dir "_login" $ withData loginRPXUser - , dir "_user" currentUser ] - --- | Returns username of logged in user or null string if nobody logged in. -currentUser :: Handler -currentUser = do - req <- askRq - ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req) diff --git a/Network/Gitit/Authentication/Github.hs b/Network/Gitit/Authentication/Github.hs deleted file mode 100644 --- a/Network/Gitit/Authentication/Github.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} - -module Network.Gitit.Authentication.Github ( loginGithubUser - , getGithubUser - , GithubCallbackPars - , GithubLoginError - , ghUserMessage - , ghDetails) where - -import Network.Gitit.Types -import Network.Gitit.Server -import Network.Gitit.State -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BSL -import Network.HTTP.Conduit -import Network.HTTP.Client.TLS -import Network.OAuth.OAuth2 -import Control.Monad (liftM, mplus, mzero) -import Data.Maybe -import Data.Aeson -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8) -import Control.Applicative -import Control.Monad.Trans (liftIO) -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import qualified Control.Exception as E -import Prelude - -loginGithubUser :: OAuth2 -> Handler -loginGithubUser githubKey = do - state <- liftIO $ fmap toString nextRandom - key <- newSession (sessionDataGithubState state) - cfg <- getConfig - addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) - let usingOrg = isJust $ org $ githubAuth cfg - let scopes = "user:email" ++ if usingOrg then ",read:org" else "" - let url = authorizationUrl githubKey `appendQueryParam` [("state", BS.pack state), ("scope", BS.pack scopes)] - seeOther (BS.unpack url) $ toResponse ("redirecting to github" :: String) - -data GithubLoginError = GithubLoginError { ghUserMessage :: String - , ghDetails :: Maybe String - } - -getGithubUser :: GithubConfig -- ^ Oauth2 configuration (client secret) - -> GithubCallbackPars -- ^ Authentication code gained after authorization - -> String -- ^ Github state, we expect the state we sent in loginGithubUser - -> GititServerPart (Either GithubLoginError User) -- ^ user email and name (password 'none') -getGithubUser ghConfig githubCallbackPars githubState = - withManagerSettings tlsManagerSettings getUserInternal - where - getUserInternal mgr = - liftIO $ do - let (Just state) = rState githubCallbackPars - if state == githubState - then do - let (Just code) = rCode githubCallbackPars - ifSuccess - "No access token found yet" - (fetchAccessToken mgr (oAuth2 ghConfig) (sToBS code)) - (\at -> ifSuccess - "User Authentication failed" - (userInfo mgr at) - (\githubUser -> ifSuccess - ("No email for user " ++ unpack (gLogin githubUser) ++ " returned by Github") - (mailInfo mgr at) - (\githubUserMail -> do - let gitLogin = gLogin githubUser - user <- mkUser (unpack gitLogin) - (unpack $ email $ head githubUserMail) - "none" - let mbOrg = org ghConfig - case mbOrg of - Nothing -> return $ Right user - Just githuborg -> ifSuccess - ("Membership check of user " ++ unpack gitLogin ++ " to " ++ unpack githuborg ++ " failed") - (orgInfo gitLogin githuborg mgr at) - (\_ -> return $ Right user)))) - else - return $ Left $ - GithubLoginError ("The state sent to github is not the same as the state received: " ++ state ++ ", but expected sent state: " ++ githubState) - Nothing - ifSuccess errMsg failableAction successAction = E.catch - (do Right outcome <- failableAction - successAction outcome) - (\exception -> liftIO $ return $ Left $ - GithubLoginError errMsg - (Just $ show (exception :: E.SomeException))) - -data GithubCallbackPars = GithubCallbackPars { rCode :: Maybe String - , rState :: Maybe String } - deriving Show - -instance FromData GithubCallbackPars where - fromData = do - vCode <- liftM Just (look "code") `mplus` return Nothing - vState <- liftM Just (look "state") `mplus` return Nothing - return GithubCallbackPars {rCode = vCode, rState = vState} - -userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser) -userInfo mgr token = authGetJSON mgr token "https://api.github.com/user" - -mailInfo :: Manager -> AccessToken -> IO (OAuth2Result [GithubUserMail]) -mailInfo mgr token = authGetJSON mgr token "https://api.github.com/user/emails" - -orgInfo :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString) -orgInfo gitLogin githubOrg mgr token = do - let url = "https://api.github.com/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin - authGetBS mgr token url - -data GithubUser = GithubUser { gLogin :: Text - } deriving (Show, Eq) - -instance FromJSON GithubUser where - parseJSON (Object o) = GithubUser - <$> o .: "login" - parseJSON _ = mzero - -data GithubUserMail = GithubUserMail { email :: Text - } deriving (Show, Eq) - -instance FromJSON GithubUserMail where - parseJSON (Object o) = GithubUserMail - <$> o .: "email" - parseJSON _ = mzero - -sToBS :: String -> BS.ByteString -sToBS = encodeUtf8 . pack diff --git a/Network/Gitit/Cache.hs b/Network/Gitit/Cache.hs deleted file mode 100644 --- a/Network/Gitit/Cache.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP #-} -{- -Copyright (C) 2008 John MacFarlane - -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 --} - -{- Functions for maintaining user list and session state. --} - -module Network.Gitit.Cache ( expireCachedFile - , lookupCache - , cacheContents ) -where - -import qualified Data.ByteString as B (ByteString, readFile, writeFile) -import System.FilePath -import System.Directory (doesFileExist, removeFile, createDirectoryIfMissing, getModificationTime) -import Data.Time.Clock (UTCTime) -#if MIN_VERSION_directory(1,2,0) -#else -import System.Time (ClockTime(..)) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -#endif -import Network.Gitit.State -import Network.Gitit.Types -import Control.Monad -import Control.Monad.Trans (liftIO) -import Text.Pandoc.UTF8 (encodePath) - --- | Expire a cached file, identified by its filename in the filestore. --- If there is an associated exported PDF, expire it too. --- Returns () after deleting a file from the cache, fails if no cached file. -expireCachedFile :: String -> GititServerPart () -expireCachedFile file = do - cfg <- getConfig - let target = encodePath $ cacheDir cfg file - exists <- liftIO $ doesFileExist target - when exists $ liftIO $ do - liftIO $ removeFile target - expireCachedPDF target (defaultExtension cfg) - -expireCachedPDF :: String -> String -> IO () -expireCachedPDF file ext = - when (takeExtension file == "." ++ ext) $ do - let pdfname = file ++ ".export.pdf" - exists <- doesFileExist pdfname - when exists $ removeFile pdfname - -lookupCache :: String -> GititServerPart (Maybe (UTCTime, B.ByteString)) -lookupCache file = do - cfg <- getConfig - let target = encodePath $ cacheDir cfg file - exists <- liftIO $ doesFileExist target - if exists - then liftIO $ do -#if MIN_VERSION_directory(1,2,0) - modtime <- getModificationTime target -#else - TOD secs _ <- getModificationTime target - let modtime = posixSecondsToUTCTime $ fromIntegral secs -#endif - contents <- B.readFile target - return $ Just (modtime, contents) - else return Nothing - -cacheContents :: String -> B.ByteString -> GititServerPart () -cacheContents file contents = do - cfg <- getConfig - let target = encodePath $ cacheDir cfg file - let targetDir = takeDirectory target - liftIO $ do - createDirectoryIfMissing True targetDir - B.writeFile target contents - expireCachedPDF target (defaultExtension cfg) diff --git a/Network/Gitit/Compat/Except.hs b/Network/Gitit/Compat/Except.hs deleted file mode 100644 --- a/Network/Gitit/Compat/Except.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE CPP #-} -module Network.Gitit.Compat.Except ( - ExceptT - , Except - , Error(..) - , runExceptT - , runExcept - , MonadError - , throwError - , catchError ) - where - -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except - -class Error a where - noMsg :: a - strMsg :: String -> a - - noMsg = strMsg "" - strMsg _ = noMsg - -#else -import Control.Monad.Error -import Control.Monad.Identity (Identity, runIdentity) - -type ExceptT = ErrorT - -type Except s a = ErrorT s Identity a - -runExceptT :: ExceptT e m a -> m (Either e a) -runExceptT = runErrorT - -runExcept :: ExceptT e Identity a -> Either e a -runExcept = runIdentity . runExceptT -#endif diff --git a/Network/Gitit/Config.hs b/Network/Gitit/Config.hs deleted file mode 100644 --- a/Network/Gitit/Config.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} -{- -Copyright (C) 2009 John MacFarlane - -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 --} - -{- | Functions for parsing command line options and reading the config file. --} - -module Network.Gitit.Config ( getConfigFromFile - , getConfigFromFiles - , getDefaultConfig - , readMimeTypesFile ) -where -import Network.Gitit.Types -import Network.Gitit.Server (mimeTypes) -import Network.Gitit.Framework -import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers) -import Network.Gitit.Util (parsePageType, readFileUTF8) -import System.Log.Logger (logM, Priority(..)) -import qualified Data.Map as M -import Data.ConfigFile hiding (readfile) -import Data.List (intercalate) -import Data.Char (toLower, toUpper, isDigit) -import Data.Text (pack) -import Paths_gitit (getDataFileName) -import System.FilePath (()) -import Text.Pandoc hiding (MathML, WebTeX, MathJax) -import qualified Control.Exception as E -import Network.OAuth.OAuth2 -import qualified Data.ByteString.Char8 as BS -import Network.Gitit.Compat.Except -import Control.Monad -import Control.Monad.Trans - -#if MIN_VERSION_pandoc(1,14,0) -import Text.Pandoc.Error (handleError) -#else -handleError :: Pandoc -> Pandoc -handleError = id -#endif - -forceEither :: Show e => Either e a -> a -forceEither = either (error . show) id - --- | Get configuration from config file. -getConfigFromFile :: FilePath -> IO Config -getConfigFromFile fname = do - cp <- getDefaultConfigParser - readfile cp fname >>= extractConfig . forceEither - --- | Get configuration from config files. -getConfigFromFiles :: [FilePath] -> IO Config -getConfigFromFiles fnames = do - config <- getConfigParserFromFiles fnames - extractConfig config - -getConfigParserFromFiles :: [FilePath] -> - IO ConfigParser -getConfigParserFromFiles (fname:fnames) = do - cp <- getConfigParserFromFiles fnames - config <- readfile cp fname - return $ forceEither config -getConfigParserFromFiles [] = getDefaultConfigParser - --- | A version of readfile that treats the file as UTF-8. -readfile :: MonadError CPError m - => ConfigParser - -> FilePath - -> IO (m ConfigParser) -readfile cp path' = do - contents <- readFileUTF8 path' - return $ readstring cp contents - -extractConfig :: ConfigParser -> IO Config -extractConfig cp = do - config' <- runExceptT $ do - cfRepositoryType <- get cp "DEFAULT" "repository-type" - cfRepositoryPath <- get cp "DEFAULT" "repository-path" - cfDefaultPageType <- get cp "DEFAULT" "default-page-type" - cfDefaultExtension <- get cp "DEFAULT" "default-extension" - cfMathMethod <- get cp "DEFAULT" "math" - cfMathjaxScript <- get cp "DEFAULT" "mathjax-script" - cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks" - cfRequireAuthentication <- get cp "DEFAULT" "require-authentication" - cfAuthenticationMethod <- get cp "DEFAULT" "authentication-method" - cfUserFile <- get cp "DEFAULT" "user-file" - cfSessionTimeout <- get cp "DEFAULT" "session-timeout" - cfTemplatesDir <- get cp "DEFAULT" "templates-dir" - cfLogFile <- get cp "DEFAULT" "log-file" - cfLogLevel <- get cp "DEFAULT" "log-level" - cfStaticDir <- get cp "DEFAULT" "static-dir" - cfPlugins <- get cp "DEFAULT" "plugins" - cfTableOfContents <- get cp "DEFAULT" "table-of-contents" - cfMaxUploadSize <- get cp "DEFAULT" "max-upload-size" - cfMaxPageSize <- get cp "DEFAULT" "max-page-size" - cfAddress <- get cp "DEFAULT" "address" - cfPort <- get cp "DEFAULT" "port" - cfDebugMode <- get cp "DEFAULT" "debug-mode" - cfFrontPage <- get cp "DEFAULT" "front-page" - cfNoEdit <- get cp "DEFAULT" "no-edit" - cfNoDelete <- get cp "DEFAULT" "no-delete" - cfDefaultSummary <- get cp "DEFAULT" "default-summary" - cfAccessQuestion <- get cp "DEFAULT" "access-question" - cfAccessQuestionAnswers <- get cp "DEFAULT" "access-question-answers" - cfUseRecaptcha <- get cp "DEFAULT" "use-recaptcha" - cfRecaptchaPublicKey <- get cp "DEFAULT" "recaptcha-public-key" - cfRecaptchaPrivateKey <- get cp "DEFAULT" "recaptcha-private-key" - cfRPXDomain <- get cp "DEFAULT" "rpx-domain" - cfRPXKey <- get cp "DEFAULT" "rpx-key" - cfCompressResponses <- get cp "DEFAULT" "compress-responses" - cfUseCache <- get cp "DEFAULT" "use-cache" - cfCacheDir <- get cp "DEFAULT" "cache-dir" - cfMimeTypesFile <- get cp "DEFAULT" "mime-types-file" - cfMailCommand <- get cp "DEFAULT" "mail-command" - cfResetPasswordMessage <- get cp "DEFAULT" "reset-password-message" - cfUseFeed <- get cp "DEFAULT" "use-feed" - cfBaseUrl <- get cp "DEFAULT" "base-url" - cfAbsoluteUrls <- get cp "DEFAULT" "absolute-urls" - cfWikiTitle <- get cp "DEFAULT" "wiki-title" - cfFeedDays <- get cp "DEFAULT" "feed-days" - cfFeedRefreshTime <- get cp "DEFAULT" "feed-refresh-time" - cfPDFExport <- get cp "DEFAULT" "pdf-export" - cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data" - cfXssSanitize <- get cp "DEFAULT" "xss-sanitize" - cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days" - let (pt, lhs) = parsePageType cfDefaultPageType - let markupHelpFile = show pt ++ if lhs then "+LHS" else "" - markupHelpPath <- liftIO $ getDataFileName $ "data" "markupHelp" markupHelpFile - markupHelpText <- liftM (writeHtmlString def . handleError . - readMarkdown def) $ - liftIO $ readFileUTF8 markupHelpPath - - mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile - let authMethod = map toLower cfAuthenticationMethod - let stripTrailingSlash = reverse . dropWhile (=='/') . reverse - let repotype' = case map toLower cfRepositoryType of - "git" -> Git - "darcs" -> Darcs - "mercurial" -> Mercurial - x -> error $ "Unknown repository type: " ++ x - when (authMethod == "rpx" && cfRPXDomain == "") $ - liftIO $ logM "gitit" WARNING "rpx-domain is not set" - ghConfig <- extractGithubConfig cp - - return Config{ - repositoryPath = cfRepositoryPath - , repositoryType = repotype' - , defaultPageType = pt - , defaultExtension = cfDefaultExtension - , mathMethod = case map toLower cfMathMethod of - "jsmath" -> JsMathScript - "mathml" -> MathML - "mathjax" -> MathJax cfMathjaxScript - "google" -> WebTeX "http://chart.apis.google.com/chart?cht=tx&chl=" - _ -> RawTeX - , defaultLHS = lhs - , showLHSBirdTracks = cfShowLHSBirdTracks - , withUser = case authMethod of - "form" -> withUserFromSession - "github" -> withUserFromSession - "http" -> withUserFromHTTPAuth - "rpx" -> withUserFromSession - _ -> id - , requireAuthentication = case map toLower cfRequireAuthentication of - "none" -> Never - "modify" -> ForModify - "read" -> ForRead - _ -> ForModify - - , authHandler = case authMethod of - "form" -> msum formAuthHandlers - "github" -> msum $ githubAuthHandlers ghConfig - "http" -> msum httpAuthHandlers - "rpx" -> msum rpxAuthHandlers - _ -> mzero - , userFile = cfUserFile - , sessionTimeout = readNumber "session-timeout" cfSessionTimeout * 60 -- convert minutes -> seconds - , templatesDir = cfTemplatesDir - , logFile = cfLogFile - , logLevel = let levelString = map toUpper cfLogLevel - levels = ["DEBUG", "INFO", "NOTICE", "WARNING", "ERROR", - "CRITICAL", "ALERT", "EMERGENCY"] - in if levelString `elem` levels - then read levelString - else error $ "Invalid log-level.\nLegal values are: " ++ intercalate ", " levels - , staticDir = cfStaticDir - , pluginModules = splitCommaList cfPlugins - , tableOfContents = cfTableOfContents - , maxUploadSize = readSize "max-upload-size" cfMaxUploadSize - , maxPageSize = readSize "max-page-size" cfMaxPageSize - , address = cfAddress - , portNumber = readNumber "port" cfPort - , debugMode = cfDebugMode - , frontPage = cfFrontPage - , noEdit = splitCommaList cfNoEdit - , noDelete = splitCommaList cfNoDelete - , defaultSummary = cfDefaultSummary - , accessQuestion = if null cfAccessQuestion - then Nothing - else Just (cfAccessQuestion, splitCommaList cfAccessQuestionAnswers) - , useRecaptcha = cfUseRecaptcha - , recaptchaPublicKey = cfRecaptchaPublicKey - , recaptchaPrivateKey = cfRecaptchaPrivateKey - , rpxDomain = cfRPXDomain - , rpxKey = cfRPXKey - , compressResponses = cfCompressResponses - , useCache = cfUseCache - , cacheDir = cfCacheDir - , mimeMap = mimeMap' - , mailCommand = cfMailCommand - , resetPasswordMessage = fromQuotedMultiline cfResetPasswordMessage - , markupHelp = markupHelpText - , useFeed = cfUseFeed - , baseUrl = stripTrailingSlash cfBaseUrl - , useAbsoluteUrls = cfAbsoluteUrls - , wikiTitle = cfWikiTitle - , feedDays = readNumber "feed-days" cfFeedDays - , feedRefreshTime = readNumber "feed-refresh-time" cfFeedRefreshTime - , pdfExport = cfPDFExport - , pandocUserData = if null cfPandocUserData - then Nothing - else Just cfPandocUserData - , xssSanitize = cfXssSanitize - , recentActivityDays = cfRecentActivityDays - , githubAuth = ghConfig - } - case config' of - Left (ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e' - Left e -> error (show e) - Right c -> return c - -extractGithubConfig :: (Functor m, MonadError CPError m) => ConfigParser - -> m GithubConfig -extractGithubConfig cp = do - cfOauthClientId <- getGithubProp "oauthClientId" - cfOauthClientSecret <- getGithubProp "oauthClientSecret" - cfOauthCallback <- getGithubProp "oauthCallback" - cfOauthOAuthorizeEndpoint <- getGithubProp "oauthOAuthorizeEndpoint" - cfOauthAccessTokenEndpoint <- getGithubProp "oauthAccessTokenEndpoint" - cfOrg <- if hasGithubProp "github-org" - then fmap Just (getGithubProp "github-org") - else return Nothing - let cfgOAuth2 = OAuth2 { oauthClientId = BS.pack cfOauthClientId - , oauthClientSecret = BS.pack cfOauthClientSecret - , oauthCallback = Just $ BS.pack cfOauthCallback - , oauthOAuthorizeEndpoint = BS.pack cfOauthOAuthorizeEndpoint - , oauthAccessTokenEndpoint = BS.pack cfOauthAccessTokenEndpoint - } - return $ githubConfig cfgOAuth2 $ fmap pack cfOrg - where getGithubProp = get cp "Github" - hasGithubProp = has_option cp "Github" - -fromQuotedMultiline :: String -> String -fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` " \t\n") - where doline = dropWhile (`elem` " \t") . dropGt - dropGt ('>':' ':xs) = xs - dropGt ('>':xs) = xs - dropGt x = x - -readNumber :: (Num a, Read a) => String -> String -> a -readNumber _ x | all isDigit x = read x -readNumber opt _ = error $ opt ++ " must be a number." - -readSize :: (Num a, Read a) => String -> String -> a -readSize opt x = - case reverse x of - ('K':_) -> readNumber opt (init x) * 1000 - ('M':_) -> readNumber opt (init x) * 1000000 - ('G':_) -> readNumber opt (init x) * 1000000000 - _ -> readNumber opt x - -splitCommaList :: String -> [String] -splitCommaList l = - let (first,rest) = break (== ',') l - first' = lrStrip first - in case rest of - [] -> if null first' then [] else [first'] - (_:rs) -> first' : splitCommaList rs - -lrStrip :: String -> String -lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace - where isWhitespace = (`elem` " \t\n") - -getDefaultConfigParser :: IO ConfigParser -getDefaultConfigParser = do - cp <- getDataFileName "data/default.conf" >>= readfile emptyCP - return $ forceEither cp - --- | Returns the default gitit configuration. -getDefaultConfig :: IO Config -getDefaultConfig = getDefaultConfigParser >>= extractConfig - --- | Read a file associating mime types with extensions, and return a --- map from extensions to types. Each line of the file consists of a --- mime type, followed by space, followed by a list of zero or more --- extensions, separated by spaces. Example: text/plain txt text -readMimeTypesFile :: FilePath -> IO (M.Map String String) -readMimeTypesFile f = E.catch - (liftM (foldr (go . words) M.empty . lines) $ readFileUTF8 f) - handleMimeTypesFileNotFound - where go [] m = m -- skip blank lines - go (x:xs) m = foldr (`M.insert` x) m xs - handleMimeTypesFileNotFound (e :: E.SomeException) = do - logM "gitit" WARNING $ "Could not read mime types file: " ++ - f ++ "\n" ++ show e ++ "\n" ++ "Using defaults instead." - return mimeTypes - -{- --- | Ready collection of common mime types. (Copied from --- Happstack.Server.HTTP.FileServe.) -mimeTypes :: M.Map String String -mimeTypes = M.fromList - [("xml","application/xml") - ,("xsl","application/xml") - ,("js","text/javascript") - ,("html","text/html") - ,("htm","text/html") - ,("css","text/css") - ,("gif","image/gif") - ,("jpg","image/jpeg") - ,("png","image/png") - ,("txt","text/plain") - ,("doc","application/msword") - ,("exe","application/octet-stream") - ,("pdf","application/pdf") - ,("zip","application/zip") - ,("gz","application/x-gzip") - ,("ps","application/postscript") - ,("rtf","application/rtf") - ,("wav","application/x-wav") - ,("hs","text/plain")] --} diff --git a/Network/Gitit/ContentTransformer.hs b/Network/Gitit/ContentTransformer.hs deleted file mode 100644 --- a/Network/Gitit/ContentTransformer.hs +++ /dev/null @@ -1,757 +0,0 @@ -{-# LANGUAGE CPP #-} -{- -Copyright (C) 2009 John MacFarlane , -Anton van Straaten - -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 --} - -{- Functions for content conversion. --} - -module Network.Gitit.ContentTransformer - ( - -- * ContentTransformer runners - runPageTransformer - , runFileTransformer - -- * Gitit responders - , showRawPage - , showFileAsText - , showPage - , exportPage - , showHighlightedSource - , showFile - , preview - , applyPreCommitPlugins - -- * Cache support for transformers - , cacheHtml - , cachedHtml - -- * Content retrieval combinators - , rawContents - -- * Response-generating combinators - , textResponse - , mimeFileResponse - , mimeResponse - , exportPandoc - , applyWikiTemplate - -- * Content-type transformation combinators - , pageToWikiPandoc - , pageToPandoc - , pandocToHtml - , highlightSource - -- * Content or context augmentation combinators - , applyPageTransforms - , wikiDivify - , addPageTitleToPandoc - , addMathSupport - , addScripts - -- * ContentTransformer context API - , getFileName - , getPageName - , getLayout - , getParams - , getCacheable - -- * Pandoc and wiki content conversion support - , inlinesToURL - , inlinesToString - ) -where - -import qualified Control.Exception as E -import Control.Monad.State -import Control.Monad.Reader (ask) -import Data.Foldable (traverse_) -import Data.List (stripPrefix) -import Data.Maybe (isNothing, mapMaybe) -import Network.Gitit.Cache (lookupCache, cacheContents) -import Network.Gitit.Export (exportFormats) -import Network.Gitit.Framework hiding (uriPath) -import Network.Gitit.Layout -import Network.Gitit.Page (stringToPage) -import Network.Gitit.Server -import Network.Gitit.State -import Network.Gitit.Types -import Network.HTTP (urlDecode) -import Network.URI (isUnescapedInURI) -import Network.URL (encString) -import System.FilePath -import qualified Text.Pandoc.Builder as B -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Text.Highlighting.Kate -import Text.Pandoc hiding (MathML, WebTeX, MathJax) -import Text.XHtml hiding ( (), dir, method, password, rev ) -import Text.XHtml.Strict (stringToHtmlString) -#if MIN_VERSION_blaze_html(0,5,0) -import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml ) -#else -import Text.Blaze.Renderer.String as Blaze ( renderHtml ) -#endif -import qualified Data.Text as T -import qualified Data.Set as Set -import qualified Data.ByteString as S (concat) -import qualified Data.ByteString.Char8 as SC (unpack) -import qualified Data.ByteString.Lazy as L (toChunks, fromChunks) -import qualified Data.FileStore as FS -import qualified Text.Pandoc as Pandoc -import Text.URI (parseURI, URI(..), uriQueryItems) - -#if MIN_VERSION_pandoc(1,14,0) -import Text.Pandoc.Error (handleError) -#else -handleError :: Pandoc -> Pandoc -handleError = id -#endif --- --- ContentTransformer runners --- - -runPageTransformer :: ToMessage a - => ContentTransformer a - -> GititServerPart a -runPageTransformer xform = withData $ \params -> do - page <- getPage - cfg <- getConfig - evalStateT xform Context{ ctxFile = pathForPage page (defaultExtension cfg) - , ctxLayout = defaultPageLayout{ - pgPageName = page - , pgTitle = page - , pgPrintable = pPrintable params - , pgMessages = pMessages params - , pgRevision = pRevision params - , pgLinkToFeed = useFeed cfg } - , ctxCacheable = True - , ctxTOC = tableOfContents cfg - , ctxBirdTracks = showLHSBirdTracks cfg - , ctxCategories = [] - , ctxMeta = [] } - -runFileTransformer :: ToMessage a - => ContentTransformer a - -> GititServerPart a -runFileTransformer xform = withData $ \params -> do - page <- getPage - cfg <- getConfig - evalStateT xform Context{ ctxFile = id page - , ctxLayout = defaultPageLayout{ - pgPageName = page - , pgTitle = page - , pgPrintable = pPrintable params - , pgMessages = pMessages params - , pgRevision = pRevision params - , pgLinkToFeed = useFeed cfg } - , ctxCacheable = True - , ctxTOC = tableOfContents cfg - , ctxBirdTracks = showLHSBirdTracks cfg - , ctxCategories = [] - , ctxMeta = [] } - --- | Converts a @ContentTransformer@ into a @GititServerPart@; --- specialized to wiki pages. --- runPageTransformer :: ToMessage a --- => ContentTransformer a --- -> GititServerPart a --- runPageTransformer = runTransformer pathForPage - --- | Converts a @ContentTransformer@ into a @GititServerPart@; --- specialized to non-pages. --- runFileTransformer :: ToMessage a --- => ContentTransformer a --- -> GititServerPart a --- runFileTransformer = runTransformer id - --- --- Gitit responders --- - --- | Responds with raw page source. -showRawPage :: Handler -showRawPage = runPageTransformer rawTextResponse - --- | Responds with raw source (for non-pages such as source --- code files). -showFileAsText :: Handler -showFileAsText = runFileTransformer rawTextResponse - --- | Responds with rendered wiki page. -showPage :: Handler -showPage = runPageTransformer htmlViaPandoc - --- | Responds with page exported into selected format. -exportPage :: Handler -exportPage = runPageTransformer exportViaPandoc - --- | Responds with highlighted source code. -showHighlightedSource :: Handler -showHighlightedSource = runFileTransformer highlightRawSource - --- | Responds with non-highlighted source code. -showFile :: Handler -showFile = runFileTransformer (rawContents >>= mimeFileResponse) - --- | Responds with rendered page derived from form data. -preview :: Handler -preview = runPageTransformer $ - liftM (filter (/= '\r') . pRaw) getParams >>= - contentsToPage >>= - pageToWikiPandoc >>= - pandocToHtml >>= - return . toResponse . renderHtmlFragment - --- | Applies pre-commit plugins to raw page source, possibly --- modifying it. -applyPreCommitPlugins :: String -> GititServerPart String -applyPreCommitPlugins = runPageTransformer . applyPreCommitTransforms - --- --- Top level, composed transformers --- - --- | Responds with raw source. -rawTextResponse :: ContentTransformer Response -rawTextResponse = rawContents >>= textResponse - --- | Responds with a wiki page in the format specified --- by the @format@ parameter. -exportViaPandoc :: ContentTransformer Response -exportViaPandoc = rawContents >>= - maybe mzero return >>= - contentsToPage >>= - pageToWikiPandoc >>= - exportPandoc - --- | Responds with a wiki page. Uses the cache when --- possible and caches the rendered page when appropriate. -htmlViaPandoc :: ContentTransformer Response -htmlViaPandoc = cachedHtml `mplus` - (rawContents >>= - maybe mzero return >>= - contentsToPage >>= - handleRedirects >>= - either return - (pageToWikiPandoc >=> - addMathSupport >=> - pandocToHtml >=> - wikiDivify >=> - applyWikiTemplate >=> - cacheHtml)) - --- | Responds with highlighted source code in a wiki --- page template. Uses the cache when possible and --- caches the rendered page when appropriate. -highlightRawSource :: ContentTransformer Response -highlightRawSource = - cachedHtml `mplus` - (updateLayout (\l -> l { pgTabs = [ViewTab,HistoryTab] }) >> - rawContents >>= - highlightSource >>= - applyWikiTemplate >>= - cacheHtml) - --- --- Cache support for transformers --- - --- | Caches a response (actually just the response body) on disk, --- unless the context indicates that the page is not cacheable. -cacheHtml :: Response -> ContentTransformer Response -cacheHtml resp' = do - params <- getParams - file <- getFileName - cacheable <- getCacheable - cfg <- lift getConfig - when (useCache cfg && cacheable && isNothing (pRevision params) && not (pPrintable params)) $ - lift $ cacheContents file $ S.concat $ L.toChunks $ rsBody resp' - return resp' - --- | Returns cached page if available, otherwise mzero. -cachedHtml :: ContentTransformer Response -cachedHtml = do - file <- getFileName - params <- getParams - cfg <- lift getConfig - if useCache cfg && not (pPrintable params) && isNothing (pRevision params) - then do mbCached <- lift $ lookupCache file - let emptyResponse = setContentType "text/html; charset=utf-8" . toResponse $ () - maybe mzero (\(_modtime, contents) -> lift . ok $ emptyResponse{rsBody = L.fromChunks [contents]}) mbCached - else mzero - --- --- Content retrieval combinators --- - --- | Returns raw file contents. -rawContents :: ContentTransformer (Maybe String) -rawContents = do - params <- getParams - file <- getFileName - fs <- lift getFileStore - let rev = pRevision params - liftIO $ E.catch (liftM Just $ FS.retrieve fs file rev) - (\e -> if e == FS.NotFound then return Nothing else E.throwIO e) - --- --- Response-generating combinators --- - --- | Converts raw contents to a text/plain response. -textResponse :: Maybe String -> ContentTransformer Response -textResponse Nothing = mzero -- fail quietly if file not found -textResponse (Just c) = mimeResponse c "text/plain; charset=utf-8" - --- | Converts raw contents to a response that is appropriate with --- a mime type derived from the page's extension. -mimeFileResponse :: Maybe String -> ContentTransformer Response -mimeFileResponse Nothing = error "Unable to retrieve file contents." -mimeFileResponse (Just c) = - mimeResponse c =<< lift . getMimeTypeForExtension . takeExtension =<< getFileName - -mimeResponse :: Monad m - => String -- ^ Raw contents for response body - -> String -- ^ Mime type - -> m Response -mimeResponse c mimeType = - return . setContentType mimeType . toResponse $ c - --- | Converts Pandoc to response using format specified in parameters. -exportPandoc :: Pandoc -> ContentTransformer Response -exportPandoc doc = do - params <- getParams - page <- getPageName - cfg <- lift getConfig - let format = pFormat params - case lookup format (exportFormats cfg) of - Nothing -> error $ "Unknown export format: " ++ format - Just writer -> lift (writer page doc) - --- | Adds the sidebar, page tabs, and other elements of the wiki page --- layout to the raw content. -applyWikiTemplate :: Html -> ContentTransformer Response -applyWikiTemplate c = do - Context { ctxLayout = layout } <- get - lift $ formattedPage layout c - --- --- Content-type transformation combinators --- - --- | Converts Page to Pandoc, applies page transforms, and adds page --- title. -pageToWikiPandoc :: Page -> ContentTransformer Pandoc -pageToWikiPandoc page' = - pageToWikiPandoc' page' >>= addPageTitleToPandoc (pageTitle page') - -pageToWikiPandoc' :: Page -> ContentTransformer Pandoc -pageToWikiPandoc' = applyPreParseTransforms >=> - pageToPandoc >=> applyPageTransforms - --- | Converts source text to Pandoc using default page type. -pageToPandoc :: Page -> ContentTransformer Pandoc -pageToPandoc page' = do - modifyContext $ \ctx -> ctx{ ctxTOC = pageTOC page' - , ctxCategories = pageCategories page' - , ctxMeta = pageMeta page' } - return $ readerFor (pageFormat page') (pageLHS page') (pageText page') - --- | Detects if the page is a redirect page and handles accordingly. The exact --- behaviour is as follows: --- --- If the page is /not/ a redirect page (the most common case), then check the --- referer to see if the client came to this page as a result of a redirect --- from another page. If so, then add a notice to the messages to notify the --- user that they were redirected from another page, and provide a link back --- to the original page, with an extra parameter to disable redirection --- (e.g., to allow the original page to be edited). --- --- If the page /is/ a redirect page, then check the query string for the --- @redirect@ parameter. This can modify the behaviour of the redirect as --- follows: --- --- 1. If the @redirect@ parameter is unset, then check the referer to see if --- client came to this page as a result of a redirect from another page. If --- so, then do not redirect, and add a notice to the messages explaining --- that this page is a redirect page, that would have redirected to the --- destination given in the metadata (and provide a link thereto), but this --- was stopped because a double-redirect was detected. This is a simple way --- to prevent cyclical redirects and other abuses enabled by redirects. --- redirect to the same page. If the client did /not/ come to this page as --- a result of a redirect, then redirect back to the same page, except with --- the redirect parameter set to @\"yes\"@. --- --- 2. If the @redirect@ parameter is set to \"yes\", then redirect to the --- destination specificed in the metadata. This uses a client-side (meta --- refresh + javascript backup) redirect to make sure the referer is set to --- this URL. --- --- 3. If the @redirect@ parameter is set to \"no\", then do not redirect, but --- add a notice to the messages that this page /would/ have redirected to --- the destination given in the metadata had it not been disabled, and --- provide a link to the destination given in the metadata. This behaviour --- is the @revision@ parameter is present in the query string. -handleRedirects :: Page -> ContentTransformer (Either Response Page) -handleRedirects page = case lookup "redirect" (pageMeta page) of - Nothing -> isn'tRedirect - Just destination -> isRedirect destination - where - addMessage message = modifyContext $ \context -> context - { ctxLayout = (ctxLayout context) - { pgMessages = pgMessages (ctxLayout context) ++ [message] - } - } - redirectedFrom source = do - (url, html) <- processSource source - return $ concat - [ "Redirected from " - , html - , "" - ] - doubleRedirect source destination = do - (url, html) <- processSource source - (url', html') <- processDestination destination - return $ concat - [ "This page normally redirects to " - , html' - , ", but as you were already redirected from " - , html - , "" - , ", this was stopped to prevent a double-redirect." - ] - cancelledRedirect destination = do - (url', html') <- processDestination destination - return $ concat - [ "This page redirects to " - , html' - , "." - ] - processSource source = do - base' <- getWikiBase - let url = stringToHtmlString $ base' ++ urlForPage source - let html = stringToHtmlString source - return (url, html) - processDestination destination = do - base' <- getWikiBase - let (page', fragment) = break (== '#') destination - let url = stringToHtmlString $ concat - [ base' - , urlForPage page' - , fragment - ] - let html = stringToHtmlString page' - return (url, html) - getSource = do - cfg <- lift getConfig - base' <- getWikiBase - request <- askRq - return $ do - uri <- getHeader "referer" request >>= parseURI . SC.unpack - let params = uriQueryItems uri - redirect' <- lookup "redirect" params - guard $ redirect' == "yes" - path' <- stripPrefix (base' ++ "/") (uriPath uri) - let path'' = if null path' then frontPage cfg else urlDecode path' - guard $ isPage path'' - return path'' - withBody = setContentType "text/html; charset=utf-8" . toResponse - isn'tRedirect = do - getSource >>= traverse_ (redirectedFrom >=> addMessage) - return (Right page) - isRedirect destination = do - params <- getParams - case maybe (pRedirect params) (\_ -> Just False) (pRevision params) of - Nothing -> do - source <- getSource - case source of - Just source' -> do - doubleRedirect source' destination >>= addMessage - return (Right page) - Nothing -> fmap Left $ do - base' <- getWikiBase - let url' = concat - [ base' - , urlForPage (pageName page) - , "?redirect=yes" - ] - lift $ seeOther url' $ withBody $ concat - [ "307 Redirect" - , "

You are being redirected.

" - ] - Just True -> fmap Left $ do - (url', html') <- processDestination destination - lift $ ok $ withBody $ concat - [ "Redirecting to " - , html' - , "

Redirecting to " - , html' - , "...

" - ] - Just False -> do - cancelledRedirect destination >>= addMessage - return (Right page) - --- | Converts contents of page file to Page object. -contentsToPage :: String -> ContentTransformer Page -contentsToPage s = do - cfg <- lift getConfig - pn <- getPageName - return $ stringToPage cfg pn s - --- | Converts pandoc document to HTML. -pandocToHtml :: Pandoc -> ContentTransformer Html -pandocToHtml pandocContents = do - base' <- lift getWikiBase - toc <- liftM ctxTOC get - bird <- liftM ctxBirdTracks get - cfg <- lift getConfig - return $ primHtml $ T.unpack . - (if xssSanitize cfg then sanitizeBalance else id) . T.pack $ - writeHtmlString def{ - writerStandalone = True - , writerTemplate = "$if(toc)$
\n$toc$\n
\n$endif$\n$body$" - , writerHTMLMathMethod = - case mathMethod cfg of - MathML -> Pandoc.MathML Nothing - WebTeX u -> Pandoc.WebTeX u - MathJax u -> Pandoc.MathJax u - _ -> JsMath (Just $ base' ++ - "/js/jsMath/easy/load.js") - , writerTableOfContents = toc - , writerHighlight = True - , writerExtensions = if bird - then Set.insert - Ext_literate_haskell - $ writerExtensions def - else writerExtensions def - -- note: javascript obfuscation gives problems on preview - , writerEmailObfuscation = ReferenceObfuscation - } pandocContents - --- | Returns highlighted source code. -highlightSource :: Maybe String -> ContentTransformer Html -highlightSource Nothing = mzero -highlightSource (Just source) = do - file <- getFileName - let formatOpts = defaultFormatOpts { numberLines = True, lineAnchors = True } - case languagesByExtension $ takeExtension file of - [] -> mzero - (l:_) -> return $ primHtml $ Blaze.renderHtml - $ formatHtmlBlock formatOpts - $! highlightAs l $ filter (/='\r') source - --- --- Plugin combinators --- - -getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc] -getPageTransforms = liftM (mapMaybe pageTransform) $ queryGititState plugins - where pageTransform (PageTransform x) = Just x - pageTransform _ = Nothing - -getPreParseTransforms :: ContentTransformer [String -> PluginM String] -getPreParseTransforms = liftM (mapMaybe preParseTransform) $ - queryGititState plugins - where preParseTransform (PreParseTransform x) = Just x - preParseTransform _ = Nothing - -getPreCommitTransforms :: ContentTransformer [String -> PluginM String] -getPreCommitTransforms = liftM (mapMaybe preCommitTransform) $ - queryGititState plugins - where preCommitTransform (PreCommitTransform x) = Just x - preCommitTransform _ = Nothing - --- | @applyTransform a t@ applies the transform @t@ to input @a@. -applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a -applyTransform inp transform = do - context <- get - conf <- lift getConfig - user <- lift getLoggedInUser - fs <- lift getFileStore - req <- lift askRq - let pluginData = PluginData{ pluginConfig = conf - , pluginUser = user - , pluginRequest = req - , pluginFileStore = fs } - (result', context') <- liftIO $ runPluginM (transform inp) pluginData context - put context' - return result' - --- | Applies all the page transform plugins to a Pandoc document. -applyPageTransforms :: Pandoc -> ContentTransformer Pandoc -applyPageTransforms c = do - xforms <- getPageTransforms - foldM applyTransform c (wikiLinksTransform : xforms) - --- | Applies all the pre-parse transform plugins to a Page object. -applyPreParseTransforms :: Page -> ContentTransformer Page -applyPreParseTransforms page' = getPreParseTransforms >>= foldM applyTransform (pageText page') >>= - (\t -> return page'{ pageText = t }) - --- | Applies all the pre-commit transform plugins to a raw string. -applyPreCommitTransforms :: String -> ContentTransformer String -applyPreCommitTransforms c = getPreCommitTransforms >>= foldM applyTransform c - --- --- Content or context augmentation combinators --- - --- | Puts rendered page content into a wikipage div, adding --- categories. -wikiDivify :: Html -> ContentTransformer Html -wikiDivify c = do - categories <- liftM ctxCategories get - base' <- lift getWikiBase - let categoryLink ctg = li (anchor ! [href $ base' ++ "/_category/" ++ ctg] << ctg) - let htmlCategories = if null categories - then noHtml - else thediv ! [identifier "categoryList"] << ulist << map categoryLink categories - return $ thediv ! [identifier "wikipage"] << [c, htmlCategories] - --- | Adds page title to a Pandoc document. -addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc -addPageTitleToPandoc title' (Pandoc _ blocks) = do - updateLayout $ \layout -> layout{ pgTitle = title' } - return $ if null title' - then Pandoc nullMeta blocks - else Pandoc (B.setMeta "title" (B.str title') nullMeta) blocks - --- | Adds javascript links for math support. -addMathSupport :: a -> ContentTransformer a -addMathSupport c = do - conf <- lift getConfig - updateLayout $ \l -> - case mathMethod conf of - JsMathScript -> addScripts l ["jsMath/easy/load.js"] - MathML -> addScripts l ["MathMLinHTML.js"] - WebTeX _ -> l - MathJax u -> addScripts l [u] - RawTeX -> l - return c - --- | Adds javascripts to page layout. -addScripts :: PageLayout -> [String] -> PageLayout -addScripts layout scriptPaths = - layout{ pgScripts = scriptPaths ++ pgScripts layout } - --- --- ContentTransformer context API --- - -getParams :: ContentTransformer Params -getParams = lift (withData return) - -getFileName :: ContentTransformer FilePath -getFileName = liftM ctxFile get - -getPageName :: ContentTransformer String -getPageName = liftM (pgPageName . ctxLayout) get - -getLayout :: ContentTransformer PageLayout -getLayout = liftM ctxLayout get - -getCacheable :: ContentTransformer Bool -getCacheable = liftM ctxCacheable get - --- | Updates the layout with the result of applying f to the current layout -updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer () -updateLayout f = do - ctx <- get - let l = ctxLayout ctx - put ctx { ctxLayout = f l } - --- --- Pandoc and wiki content conversion support --- - -readerFor :: PageType -> Bool -> String -> Pandoc -readerFor pt lhs = - let defPS = def{ readerSmart = True - , readerExtensions = if lhs - then Set.insert Ext_literate_haskell - $ readerExtensions def - else readerExtensions def - , readerParseRaw = True - } - in handleError . case pt of - RST -> readRST defPS - Markdown -> readMarkdown defPS -#if MIN_VERSION_pandoc(1,14,0) - CommonMark -> readCommonMark defPS -#else - CommonMark -> error "CommonMark input requires pandoc 1.14" -#endif - LaTeX -> readLaTeX defPS - HTML -> readHtml defPS - Textile -> readTextile defPS - Org -> readOrg defPS - DocBook -> readDocBook defPS - MediaWiki -> readMediaWiki defPS - -wikiLinksTransform :: Pandoc -> PluginM Pandoc -wikiLinksTransform pandoc - = do cfg <- liftM pluginConfig ask -- Can't use askConfig from Interface due to circular dependencies. - return (bottomUp (convertWikiLinks cfg) pandoc) - --- | Convert links with no URL to wikilinks. -convertWikiLinks :: Config -> Inline -> Inline -convertWikiLinks cfg (Link ref ("", "")) | useAbsoluteUrls cfg = - Link ref ("/" baseUrl cfg inlinesToURL ref, "Go to wiki page") -convertWikiLinks _cfg (Link ref ("", "")) = - Link ref (inlinesToURL ref, "Go to wiki page") -convertWikiLinks _cfg x = x - --- | Derives a URL from a list of Pandoc Inline elements. -inlinesToURL :: [Inline] -> String -inlinesToURL = encString False isUnescapedInURI . inlinesToString - --- | Convert a list of inlines into a string. -inlinesToString :: [Inline] -> String -inlinesToString = concatMap go - where go x = case x of - Str s -> s - Emph xs -> concatMap go xs - Strong xs -> concatMap go xs - Strikeout xs -> concatMap go xs - Superscript xs -> concatMap go xs - Subscript xs -> concatMap go xs - SmallCaps xs -> concatMap go xs - Quoted DoubleQuote xs -> '"' : (concatMap go xs ++ "\"") - Quoted SingleQuote xs -> '\'' : (concatMap go xs ++ "'") - Cite _ xs -> concatMap go xs - Code _ s -> s - Space -> " " - LineBreak -> " " - Math DisplayMath s -> "$$" ++ s ++ "$$" - Math InlineMath s -> "$" ++ s ++ "$" - RawInline (Format "tex") s -> s - RawInline _ _ -> "" - Link xs _ -> concatMap go xs - Image xs _ -> concatMap go xs - Note _ -> "" - Span _ xs -> concatMap go xs - diff --git a/Network/Gitit/Export.hs b/Network/Gitit/Export.hs deleted file mode 100644 --- a/Network/Gitit/Export.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} -{- -Copyright (C) 2009 John MacFarlane - -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 --} - -{- Functions for exporting wiki pages in various formats. --} - -module Network.Gitit.Export ( exportFormats ) where -import Text.Pandoc hiding (HTMLMathMethod(..)) -import qualified Text.Pandoc as Pandoc -import Text.Pandoc.PDF (makePDF) -import Text.Pandoc.SelfContained as SelfContained -import Text.Pandoc.Shared (readDataFileUTF8) -import Network.Gitit.Server -import Network.Gitit.Framework (pathForPage, getWikiBase) -import Network.Gitit.State (getConfig) -import Network.Gitit.Types -import Network.Gitit.Cache (cacheContents, lookupCache) -import Control.Monad.Trans (liftIO) -import Control.Monad (unless) -import Text.XHtml (noHtml) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.UTF8 (fromString, toString) -import System.FilePath ((), takeDirectory) -import Control.Exception (throwIO) -import System.Directory (doesFileExist) -import Text.HTML.SanitizeXSS -import Text.Pandoc.Writers.RTF (writeRTFWithEmbeddedImages) -import qualified Data.Text as T -import Data.List (isPrefixOf) -import Text.Highlighting.Kate (styleToCss, pygments) -import Paths_gitit (getDataFileName) - -defaultRespOptions :: WriterOptions -defaultRespOptions = def { writerStandalone = True, writerHighlight = True } - -respond :: String - -> String - -> (Pandoc -> IO L.ByteString) - -> String - -> Pandoc - -> Handler -respond mimetype ext fn page doc = liftIO (fn doc) >>= - ok . setContentType mimetype . - (if null ext then id else setFilename (page ++ "." ++ ext)) . - toResponseBS B.empty - -respondX :: String -> String -> String - -> (WriterOptions -> Pandoc -> IO L.ByteString) - -> WriterOptions -> String -> Pandoc -> Handler -respondX templ mimetype ext fn opts page doc = do - cfg <- getConfig - template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ - template <- case template' of - Right t -> return t - Left e -> liftIO $ throwIO e - doc' <- if ext `elem` ["odt","pdf","beamer","epub","docx","rtf"] - then fixURLs page doc - else return doc - respond mimetype ext (fn opts{writerTemplate = template - ,writerUserDataDir = pandocUserData cfg}) - page doc' - -respondS :: String -> String -> String -> (WriterOptions -> Pandoc -> String) - -> WriterOptions -> String -> Pandoc -> Handler -respondS templ mimetype ext fn = - respondX templ mimetype ext (\o d -> return $ fromString $ fn o d) - -respondSlides :: String -> HTMLSlideVariant -> String -> Pandoc -> Handler -respondSlides templ slideVariant page doc = do - cfg <- getConfig - base' <- getWikiBase - let math = case mathMethod cfg of - MathML -> Pandoc.MathML Nothing - WebTeX u -> Pandoc.WebTeX u - JsMathScript -> Pandoc.JsMath - (Just $ base' ++ "/js/jsMath/easy/load.js") - _ -> Pandoc.PlainMath - let opts' = defaultRespOptions { - writerSlideVariant = slideVariant - ,writerIncremental = True - ,writerHtml5 = templ == "dzslides" - ,writerHTMLMathMethod = math} - -- We sanitize the body only, to protect against XSS attacks. - -- (Sanitizing the whole HTML page would strip out javascript - -- needed for the slides.) We then pass the body into the - -- slide template using the 'body' variable. - Pandoc meta blocks <- fixURLs page doc - let body' = writeHtmlString opts'{writerStandalone = False} - (Pandoc meta blocks) -- just body - let body'' = T.unpack - $ (if xssSanitize cfg then sanitizeBalance else id) - $ T.pack body' - variables' <- if mathMethod cfg == MathML - then do - s <- liftIO $ readDataFileUTF8 (pandocUserData cfg) - "MathMLinHTML.js" - return [("mathml-script", s)] - else return [] - template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ - template <- case template' of - Right t -> return t - Left e -> liftIO $ throwIO e - dzcore <- if templ == "dzslides" - then do - dztempl <- liftIO $ readDataFileUTF8 (pandocUserData cfg) - $ "dzslides" "template.html" - return $ unlines - $ dropWhile (not . isPrefixOf "