diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,13 @@ +Version 0.5.1 released 1 Feb 2009 + +* Major code reorganization, making gitit more modular. +* Gitit can now optionally be built using Happstack instead of HAppS + (just use -fhappstack when cabal installing). +* Fixed bug with directories that had the same names as pages. +* Added code from HAppS-Extra to fix cookie parsing problems. +* New command-line options for --port, --debug. +* New debug feature prints the date, the raw request, and + the processed request data to standard output on each request. +* Files with ".page" extension can no longer be uploaded. +* Apostrophes and quotation marks now allowed in page names. + diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -19,218 +19,97 @@ module Main where -import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie) -import Gitit.HAppS (look, lookRead, lookCookieValue, mkCookie) -import System.Environment +import Gitit.Server +import Gitit.Util (orIfNull, consolidateHeads) +import Gitit.Initialize (createStaticIfMissing, createRepoIfMissing) +import Gitit.Framework +import Gitit.Layout +import Gitit.Convert +import Gitit.Export (exportFormats) import System.IO.UTF8 import System.IO (stderr) -import System.IO.Error (isAlreadyExistsError) -import Control.Exception (bracket, throwIO, catch, try) +import Control.Exception (throwIO, catch, try) import Prelude hiding (writeFile, readFile, putStrLn, putStr, catch) import System.Directory import System.Time import Control.Concurrent import System.FilePath import Gitit.State +import Gitit.Config (getConfigFromOpts) import Text.XHtml hiding ( (), dir, method, password, rev ) import qualified Text.XHtml as X ( password, method ) -import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf, find, isPrefixOf) -import Data.Maybe (fromMaybe, fromJust, mapMaybe, isJust, isNothing) -import Data.ByteString.UTF8 (fromString, toString) -import Codec.Binary.UTF8.String (decodeString, encodeString) +import Data.List (intersperse, sort, nub, sortBy, isSuffixOf, find, isPrefixOf) +import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) +import Codec.Binary.UTF8.String (encodeString) import qualified Data.Map as M import Data.Ord (comparing) import Paths_gitit import Text.Pandoc -import Text.Pandoc.ODT (saveOpenDocumentAsODT) -import Text.Pandoc.Definition (processPandoc) -import Text.Pandoc.Shared (HTMLMathMethod(..), substitute) +import Text.Pandoc.Shared (substitute) import Data.Char (isAlphaNum, isAlpha, toLower) import Control.Monad.Reader import qualified Data.ByteString.Lazy as B -import Codec.Compression.GZip (compress) -import Network.HTTP (urlEncodeVars, urlEncode) -import System.Console.GetOpt -import System.Exit +import Network.HTTP (urlEncodeVars) import Text.Highlighting.Kate import qualified Text.StringTemplate as T -import Data.DateTime (getCurrentTime, addMinutes, parseDateTime, DateTime, formatDateTime) -import Network.Socket +import Data.DateTime (getCurrentTime, addMinutes, formatDateTime) import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) import Data.FileStore -gititVersion :: String -gititVersion = "0.5" -sessionTime :: Int -sessionTime = 60 * 60 -- session will expire 1 hour after page request - main :: IO () main = do - argv <- getArgs - options <- parseArgs argv - conf <- foldM handleFlag defaultConfig options + + -- parse options to get config file + conf <- getConfigFromOpts + -- check for external programs that are needed let prereqs = "grep" : case repository conf of Git _ -> ["git"] Darcs _ -> ["darcs"] forM_ prereqs $ \prog -> findExecutable prog >>= \mbFind -> - when (isNothing mbFind) $ error $ "Required program '" ++ prog ++ "' not found in system path." + when (isNothing mbFind) $ error $ + "Required program '" ++ prog ++ "' not found in system path." + -- read user file and update state userFileExists <- doesFileExist $ userFile conf users' <- if userFileExists - then readFile (userFile conf) >>= (return . M.fromList . read) + then liftM (M.fromList . read) $ readFile $ userFile conf else return M.empty - -- create template file if it doesn't exist, and read it + + -- create template file if it doesn't exist let templatefile = templateFile conf templateExists <- doesFileExist templatefile unless templateExists $ do templatePath <- getDataFileName $ "data" "template.html" copyFile templatePath templatefile hPutStrLn stderr $ "Created " ++ templatefile - templ <- liftIO $ readFile (templateFile conf) + + -- read template file + templ <- liftM T.newSTMP $ liftIO $ readFile templatefile + -- initialize state - initializeAppState conf users' (T.newSTMP templ) + initializeAppState conf users' templ + -- setup the page repository and static files, if they don't exist - initializeWiki conf + createRepoIfMissing conf + let staticdir = staticDir conf + createStaticIfMissing staticdir + -- start the server hPutStrLn stderr $ "Starting server on port " ++ show (portNumber conf) - let debugger = if debugMode conf then debugFilter else id tid <- forkIO $ simpleHTTP (Conf { validator = Nothing, port = portNumber conf }) $ - debugger $ - [ dir "css" [ withExpiresHeaders $ fileServe [] $ staticDir conf "css" ] - , dir "img" [ withExpiresHeaders $ fileServe [] $ staticDir conf "img" ] - , dir "js" [ withExpiresHeaders $ fileServe [] $ staticDir conf "js" ] - ] ++ - (if debugMode conf then debugHandlers else []) ++ - map (filterIf acceptsZip gzipBinary) wikiHandlers + map (\d -> dir d [ withExpiresHeaders $ fileServe [] $ staticdir d]) ["css", "img", "js"] ++ + [ debugHandler | debugMode conf ] ++ + [ filterIf acceptsZip gzipBinary $ cookieFixer $ multi wikiHandlers ] waitForTermination + + -- shut down the server putStrLn "Shutting down..." killThread tid putStrLn "Shutdown complete" -filterIf :: (Request -> Bool) -> (Response -> Response) -> ServerPart Response -> ServerPart Response -filterIf test filt sp = - let handler = unServerPartT sp - in withRequest $ \req -> - if test req - then liftM filt $ handler req - else handler req - -gzipBinary :: Response -> Response -gzipBinary r@(Response {rsBody = b}) = setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b} - -acceptsZip :: Request -> Bool -acceptsZip req = isJust $ M.lookup (fromString "accept-encoding") (rqHeaders req) - -getCacheTime :: IO (Maybe DateTime) -getCacheTime = liftM (Just . addMinutes 360) $ getCurrentTime - -withExpiresHeaders :: ServerPart Response -> ServerPart Response -withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp] - -setContentType :: String -> Response -> Response -setContentType = setHeader "Content-Type" - -setFilename :: String -> Response -> Response -setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\"" - -data Opt - = Help - | ConfigFile FilePath - | Version - deriving (Eq) - -flags :: [OptDescr Opt] -flags = - [ Option ['h'] [] (NoArg Help) - "Print this help message" - , Option ['v'] [] (NoArg Version) - "Print version information" - , Option ['f'] [] (ReqArg ConfigFile "FILE") - "Specify configuration file" - ] - -parseArgs :: [String] -> IO [Opt] -parseArgs argv = do - progname <- getProgName - case getOpt Permute flags argv of - (opts,_,[]) -> return opts - (_,_,errs) -> hPutStrLn stderr (concat errs ++ usageInfo (usageHeader progname) flags) >> - exitWith (ExitFailure 1) - -usageHeader :: String -> String -usageHeader progname = "Usage: " ++ progname ++ " [opts...]" - -copyrightMessage :: String -copyrightMessage = "\nCopyright (C) 2008 John MacFarlane\n" ++ - "This is free software; see the source for copying conditions. There is no\n" ++ - "warranty, not even for merchantability or fitness for a particular purpose." - -handleFlag :: Config -> Opt -> IO Config -handleFlag _ opt = do - progname <- getProgName - case opt of - Help -> hPutStrLn stderr (usageInfo (usageHeader progname) flags) >> exitWith ExitSuccess - Version -> hPutStrLn stderr (progname ++ " version " ++ gititVersion ++ copyrightMessage) >> exitWith ExitSuccess - ConfigFile f -> liftM read (readFile f) - --- | Create repository and public directories, unless they already exist. -initializeWiki :: Config -> IO () -initializeWiki conf = do - let staticdir = staticDir conf - fs <- getFileStore - repoExists <- liftIO $ catch (initialize fs >> return False) - (\e -> if e == RepositoryExists then return True else throwIO e >> return False) - unless repoExists $ do - welcomepath <- getDataFileName $ "data" "FrontPage.page" - welcomecontents <- B.readFile welcomepath - helppath <- getDataFileName $ "data" "Help.page" - helpcontents <- B.readFile helppath - -- add front page and help page - liftIO $ create fs (frontPage conf <.> "page") (Author "Gitit" "") "Default front page" welcomecontents - liftIO $ create fs "Help.page" (Author "Gitit" "") "Default front page" helpcontents - hPutStrLn stderr "Created repository" - staticExists <- doesDirectoryExist staticdir - unless staticExists $ do - createDirectoryIfMissing True $ staticdir "css" - let stylesheets = map ("css" ) ["screen.css", "print.css", "ie.css", "hk-pyg.css"] - stylesheetpaths <- mapM getDataFileName stylesheets - zipWithM_ copyFile stylesheetpaths (map (staticdir ) stylesheets) - createDirectoryIfMissing True $ staticdir "img" "icons" - let imgs = map (("img" ) . ("icons" )) - ["cross.png", "doc.png", "email.png", "external.png", "feed.png", "folder.png", - "im.png", "key.png", "page.png", "pdf.png", "tick.png", "xls.png"] - imgpaths <- mapM getDataFileName imgs - zipWithM_ copyFile imgpaths (map (staticdir ) imgs) - logopath <- getDataFileName $ "img" "gitit-dog.png" - copyFile logopath (staticdir "img" "logo.png") - createDirectoryIfMissing True $ staticdir "js" - let javascripts = ["jquery.min.js", "jquery-ui.packed.js", - "folding.js", "dragdiff.js", "preview.js", "search.js", "uploadForm.js"] - javascriptpaths <- mapM getDataFileName $ map ("js" ) javascripts - zipWithM_ copyFile javascriptpaths $ map ((staticdir "js") ) javascripts - hPutStrLn stderr $ "Created " ++ staticdir ++ " directory" - jsMathExists <- doesDirectoryExist (staticdir "js" "jsMath") - updateAppState $ \s -> s{ jsMath = jsMathExists } - unless jsMathExists $ do - hPutStrLn stderr $ replicate 80 '*' ++ - "\nWarning: jsMath not found.\n" ++ - "If you want support for math, copy the jsMath directory into " ++ staticdir ++ "/js/\n" ++ - "jsMath can be obtained from http://www.math.union.edu/~dpvc/jsMath/\n" ++ - replicate 80 '*' - -type Handler = ServerPart Response - - -debugHandlers :: [Handler] -debugHandlers = [ withCommand "params" [ handlePage GET $ \_ params -> ok (toResponse $ show params), - handlePage POST $ \_ params -> ok (toResponse $ show params) ] - , withCommand "page" [ handlePage GET $ \page _ -> ok (toResponse $ show page), - handlePage POST $ \page _ -> ok (toResponse $ show page) ] - , withCommand "request" [ withRequest $ \req -> ok $ toResponse $ show req ] ] - wikiHandlers :: [Handler] wikiHandlers = [ handlePath "_index" GET indexPage , handlePath "_activity" GET showActivity @@ -243,241 +122,34 @@ , handlePath "_login" GET loginUserForm , handlePath "_login" POST loginUser , handlePath "_logout" GET logoutUser - , handlePath "_upload" GET (ifLoggedIn uploadForm) - , handlePath "_upload" POST (ifLoggedIn uploadFile) + , handlePath "_upload" GET (ifLoggedIn uploadForm loginUserForm) + , handlePath "_upload" POST (ifLoggedIn uploadFile loginUserForm) , handlePath "_random" GET randomPage , handlePath "" GET showFrontPage , withCommand "showraw" [ handlePage GET showRawPage ] , withCommand "history" [ handlePage GET showPageHistory, handle (not . isPage) GET showFileHistory ] - , withCommand "edit" [ handlePage GET $ unlessNoEdit $ ifLoggedIn editPage ] + , withCommand "edit" [ handlePage GET $ unlessNoEdit (ifLoggedIn editPage loginUserForm) showPage ] , withCommand "diff" [ handlePage GET showPageDiff, handle isSourceCode GET showFileDiff ] , withCommand "export" [ handlePage POST exportPage, handlePage GET exportPage ] , withCommand "cancel" [ handlePage POST showPage ] , withCommand "discuss" [ handlePage GET discussPage ] - , withCommand "update" [ handlePage POST $ unlessNoEdit $ ifLoggedIn updatePage ] - , withCommand "delete" [ handlePage GET $ unlessNoDelete $ ifLoggedIn confirmDelete, - handlePage POST $ unlessNoDelete $ ifLoggedIn deletePage ] + , withCommand "update" [ handlePage POST $ unlessNoEdit (ifLoggedIn updatePage loginUserForm) showPage ] + , withCommand "delete" [ handlePage GET $ unlessNoDelete (ifLoggedIn confirmDelete loginUserForm) showPage, + handlePage POST $ unlessNoDelete (ifLoggedIn deletePage loginUserForm) showPage ] + , handlePage GET showPage , handleSourceCode , handleAny - , handlePage GET showPage + , handlePage GET createPage ] -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 - , pIPAddress :: 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 } - , pIPAddress = "" -- this gets set by handle... - } - -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 - -data Command = Command (Maybe String) - -commandList :: [String] -commandList = ["page", "request", "params", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"] - -instance FromData Command where - fromData = do - pairs <- lookPairs - return $ case map fst pairs `intersect` commandList of - [] -> Command Nothing - (c:_) -> Command $ Just c - -unlessNoEdit :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) -unlessNoEdit responder = - \page params -> do cfg <- getConfig - if page `elem` noEdit cfg - then showPage page (params { pMessages = ("Page is locked." : pMessages params) }) - else responder page params - -unlessNoDelete :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) -unlessNoDelete responder = - \page params -> do cfg <- getConfig - if page `elem` noDelete cfg - then showPage page (params { pMessages = ("Page cannot be deleted." : pMessages params) }) - else responder page params - -ifLoggedIn :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) -ifLoggedIn responder = - \page params -> do user <- getLoggedInUser params - case user of - Nothing -> do - loginUserForm 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 }) - -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 - mbIPaddr <- liftIO $ lookupIPAddr peer - let ipaddr = case mbIPaddr of - Just ip -> ip - Nothing -> "0.0.0.0" - -- force ipaddr to be strictly evaluated, or we run into problems when validating captchas - ipaddr `seq` responder path' (params { pReferer = referer, - pUri = uri, - pIPAddress = ipaddr }) - else noHandle ] - else anyRequest noHandle - -lookupIPAddr :: String -> IO (Maybe String) -lookupIPAddr hostname = do - addrs <- getAddrInfo (Just defaultHints) (Just hostname) Nothing - if null addrs - then return Nothing - else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ head addrs - --- | 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 (/='?') - -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 - _ -> [] - handleSourceCode :: Handler handleSourceCode = withData $ \com -> case com of Command (Just "showraw") -> [ handle isSourceCode GET showFileAsText ] _ -> [ handle isSourceCode GET showHighlightedSource ] - handleAny :: Handler handleAny = uriRest $ \uri -> let path' = uriPath uri @@ -490,33 +162,14 @@ Left NotFound -> anyRequest noHandle Left e -> error (show e) -orIfNull :: String -> String -> String -orIfNull str backup = if null str then backup else str - -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 +debugHandler :: Handler +debugHandler = do + liftIO $ putStr "\n" + withRequest $ \req -> liftIO $ getCurrentTime >>= (putStrLn . formatDateTime "%c") >> putStrLn (show req) + multi [ handle (const True) GET showParams, handle (const True) POST showParams ] + where showParams page params = do + liftIO $ putStrLn page >> putStrLn (show params) + noHandle showRawPage :: String -> Params -> Web Response showRawPage = showFileAsText . pathForPage @@ -571,7 +224,7 @@ rev <- liftIO $ latest fs (pathForPage page) cacheContents (pathForPage page) rev c formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js" | jsMathExists]}) page params c - Nothing -> createPage page params + Nothing -> noHandle discussPage :: String -> Params -> Web Response discussPage page params = do @@ -585,11 +238,6 @@ p << [ stringToHtml ("There is no page '" ++ page ++ "'. You may create the page by ") , anchor ! [href $ urlForPage page ++ "?edit"] << "clicking here." ] -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 - uploadForm :: String -> Params -> Web Response uploadForm _ params = do let page = "_upload" @@ -629,7 +277,7 @@ "or check the box to overwrite the existing file existing file.") , (B.length fileContents > fromIntegral (maxUploadSize cfg), "File exceeds maximum upload size.") - , (isPage wikiname, + , (takeExtension wikiname == ".page", "This file extension is reserved for wiki pages.") ] if null errors @@ -897,14 +545,6 @@ let htmlIndex = fileListToHtml "/" $ map splitPath $ sort $ filter (\f -> not (":discuss.page" `isSuffixOf` f)) files formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgScripts = ["folding.js"], pgTitle = "All pages" }) page params htmlIndex --- | Map a list of nonempty lists onto a list of pairs of list heads and list of tails. --- e.g. [[1,2],[1],[2,1]] -> [(1,[[2],[]]), (2,[[1]])] -consolidateHeads :: Eq a => [[a]] -> [(a,[[a]])] -consolidateHeads lst = - let heads = nub $ map head lst - tailsFor h = map tail [l | l <- lst, head l == h] - in map (\h -> (h, tailsFor h)) heads - -- | Create a hierarchical ordered list (with links) for a list of files fileListToHtml :: String -> [[FilePath]] -> Html fileListToHtml prefix lst = ulist ! [identifier "index", theclass "folding"] << @@ -914,127 +554,6 @@ else li ! [theclass "folder"] << [stringToHtml h', fileListToHtml (prefix ++ h') l]) $ consolidateHeads lst) --- | Convert links with no URL to wikilinks, if their labels are all strings and spaces -convertWikiLinks :: Inline -> Inline -convertWikiLinks (Link ref ("", "")) | all isStringOrSpace ref = - Link ref (refToUrl ref, "Go to wiki page") -convertWikiLinks x = x - -isStringOrSpace :: Inline -> Bool -isStringOrSpace Space = True -isStringOrSpace (Str _) = True -isStringOrSpace _ = False - -refToUrl :: [Inline] -> String -refToUrl ((Str x):xs) = x ++ refToUrl xs -refToUrl (Space:xs) = "%20" ++ refToUrl xs -refToUrl (_:_) = error "Encountered an inline other than Str or Space" -refToUrl [] = "" - --- | Converts pandoc document to HTML. -pandocToHtml :: MonadIO m => Pandoc -> m Html -pandocToHtml pandocContents = do - cfg <- getConfig - return $ writeHtml (defaultWriterOptions { writerStandalone = False - , writerHTMLMathMethod = JsMath (Just "/js/jsMath/easy/load.js") - , writerTableOfContents = tableOfContents cfg - }) $ processPandoc convertWikiLinks pandocContents - --- | Abstract representation of page layout (tabs, scripts, etc.) -data PageLayout = PageLayout - { pgTitle :: String - , pgScripts :: [String] - , pgShowPageTools :: Bool - , pgTabs :: [Tab] - , pgSelectedTab :: Tab - } - -data Tab = ViewTab | EditTab | HistoryTab | DiscussTab | DiffTab deriving (Eq, Show) - -defaultPageLayout :: PageLayout -defaultPageLayout = PageLayout - { pgTitle = "" - , pgScripts = [] - , pgShowPageTools = True - , pgTabs = [ViewTab, EditTab, HistoryTab, DiscussTab] - , pgSelectedTab = ViewTab - } - --- | Returns formatted page -formattedPage :: PageLayout -> String -> Params -> Html -> Web Response -formattedPage layout page params htmlContents = do - let rev = pRevision params - let path' = if isPage page then pathForPage page else page - fs <- getFileStore - sha1 <- case rev of - Nothing -> liftIO $ catch (latest fs path') - (\e -> if e == NotFound - then return "" - else throwIO e) - Just r -> return r - user <- getLoggedInUser params - let javascriptlinks = if null (pgScripts layout) - then "" - else renderHtmlFragment $ concatHtml $ map - (\x -> script ! [src ("/js/" ++ x), thetype "text/javascript"] << noHtml) - (["jquery.min.js", "jquery-ui.packed.js"] ++ pgScripts layout) - let pageTitle = pgTitle layout `orIfNull` page - let tabli tab = if tab == pgSelectedTab layout - then li ! [theclass "selected"] - else li - let origPage s = if ":discuss" `isSuffixOf` s then take (length s - 8) s else s - let linkForTab HistoryTab = Just $ tabli HistoryTab << anchor ! [href $ urlForPage page ++ "?history" ++ - case rev of { Just r -> "&revision" ++ r; Nothing -> "" }] << "history" - linkForTab DiffTab = Just $ tabli DiffTab << anchor ! [href ""] << "diff" - linkForTab ViewTab = if isDiscussPage page - then Just $ tabli DiscussTab << anchor ! [href $ urlForPage $ origPage page] << "page" - else Just $ tabli ViewTab << anchor ! [href $ urlForPage page ++ - case rev of { Just r -> "?revision=" ++ r; Nothing -> "" }] << "view" - linkForTab DiscussTab = if isDiscussPage page - then Just $ tabli ViewTab << anchor ! [href $ urlForPage page] << "discuss" - else if isPage page - then Just $ tabli DiscussTab << anchor ! [href $ urlForPage page ++ "?discuss"] << "discuss" - else Nothing - linkForTab EditTab = if isPage page - then Just $ tabli EditTab << anchor ! [href $ urlForPage page ++ "?edit" ++ - (case rev of - Just r -> "&revision=" ++ r ++ "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ r)] - Nothing -> "")] << - if isNothing rev then "edit" else "revert" - else Nothing - let tabs = ulist ! [theclass "tabs"] << mapMaybe linkForTab (pgTabs layout) - let searchbox = gui ("/_search") ! [identifier "searchform"] << - [ textfield "patterns" - , submit "search" "Search" ] - let gobox = gui ("/_go") ! [identifier "goform"] << - [ textfield "gotopage" - , submit "go" "Go" ] - let messages = pMessages params - let htmlMessages = if null messages - then noHtml - else ulist ! [theclass "messages"] << map (li <<) messages - templ <- queryAppState template - let filledTemp = T.render $ - T.setAttribute "pagetitle" pageTitle $ - T.setAttribute "javascripts" javascriptlinks $ - T.setAttribute "pagename" page $ - (case user of - Just u -> T.setAttribute "user" u - Nothing -> id) $ - (if isPage page then T.setAttribute "ispage" "true" else id) $ - (if pgShowPageTools layout then T.setAttribute "pagetools" "true" else id) $ - (if pPrintable params then T.setAttribute "printable" "true" else id) $ - (if isJust rev then T.setAttribute "nothead" "true" else id) $ - (if isJust rev then T.setAttribute "revision" (fromJust rev) else id) $ - T.setAttribute "sha1" sha1 $ - T.setAttribute "searchbox" (renderHtmlFragment (searchbox +++ gobox)) $ - T.setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ - T.setAttribute "tabs" (renderHtmlFragment tabs) $ - T.setAttribute "messages" (renderHtmlFragment htmlMessages) $ - T.setAttribute "content" (renderHtmlFragment htmlContents) $ - templ - ok $ setContentType "text/html" $ toResponse $ encodeString filledTemp - -- user authentication loginForm :: Html loginForm = @@ -1129,8 +648,13 @@ captchaResult <- if useRecaptcha cfg then if null (recaptchaChallengeField recaptcha) || null (recaptchaResponseField recaptcha) then return $ Left "missing-challenge-or-response" -- no need to bother captcha.net in this case - else liftIO $ validateCaptcha (recaptchaPrivateKey cfg) (pIPAddress params) (recaptchaChallengeField recaptcha) - (recaptchaResponseField recaptcha) + else liftIO $ do + mbIPaddr <- lookupIPAddr $ pPeer params + let ipaddr = case mbIPaddr of + Just ip -> ip + Nothing -> error $ "Could not find ip address for " ++ pPeer params + ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg) ipaddr (recaptchaChallengeField recaptcha) + (recaptchaResponseField recaptcha) else return $ Right () let (validCaptcha, captchaError) = case captchaResult of Right () -> (True, Nothing) @@ -1172,79 +696,15 @@ formattedPage defaultPageLayout file params $ formattedContents Nothing -> noHandle -defaultRespOptions :: WriterOptions -defaultRespOptions = defaultWriterOptions { writerStandalone = True, writerWrapText = True } - -respondLaTeX :: String -> Pandoc -> Web Response -respondLaTeX page = ok . setContentType "application/x-latex" . setFilename (page ++ ".tex") . toResponse . encodeString . - writeLaTeX (defaultRespOptions {writerHeader = defaultLaTeXHeader}) - -respondConTeXt :: String -> Pandoc -> Web Response -respondConTeXt page = ok . setContentType "application/x-context" . setFilename (page ++ ".tex") . toResponse . encodeString . - writeConTeXt (defaultRespOptions {writerHeader = defaultConTeXtHeader}) - -respondRTF :: String -> Pandoc -> Web Response -respondRTF page = ok . setContentType "application/rtf" . setFilename (page ++ ".rtf") . toResponse . encodeString . - writeRTF (defaultRespOptions {writerHeader = defaultRTFHeader}) - -respondRST :: String -> Pandoc -> Web Response -respondRST _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . - writeRST (defaultRespOptions {writerHeader = "", writerReferenceLinks = True}) - -respondMan :: String -> Pandoc -> Web Response -respondMan _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . - writeMan (defaultRespOptions {writerHeader = ""}) - -respondS5 :: String -> Pandoc -> Web Response -respondS5 _ = ok . toResponse . writeS5 (defaultRespOptions {writerHeader = defaultS5Header, - writerS5 = True, writerIncremental = True}) - -respondTexinfo :: String -> Pandoc -> Web Response -respondTexinfo page = ok . setContentType "application/x-texinfo" . setFilename (page ++ ".texi") . toResponse . encodeString . - writeTexinfo (defaultRespOptions {writerHeader = ""}) - -respondDocbook :: String -> Pandoc -> Web Response -respondDocbook page = ok . setContentType "application/docbook+xml" . setFilename (page ++ ".xml") . toResponse . encodeString . - writeDocbook (defaultRespOptions {writerHeader = defaultDocbookHeader}) - -respondMediaWiki :: String -> Pandoc -> Web Response -respondMediaWiki _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . - writeMediaWiki (defaultRespOptions {writerHeader = ""}) - -respondODT :: String -> Pandoc -> Web Response -respondODT page doc = do - let openDoc = writeOpenDocument (defaultRespOptions {writerHeader = defaultOpenDocumentHeader}) doc - contents <- liftIO $ withTempDir "gitit-temp-odt" $ \tempdir -> do - let tempfile = tempdir page <.> "odt" - conf <- getConfig - let repoPath = case repository conf of - Git path' -> path' - Darcs path' -> path' - saveOpenDocumentAsODT tempfile repoPath openDoc - B.readFile tempfile - ok $ setContentType "application/vnd.oasis.opendocument.text" $ setFilename (page ++ ".odt") $ (toResponse noHtml) {rsBody = contents} - -exportFormats :: [(String, String -> Pandoc -> Web Response)] -- (description, writer) -exportFormats = [ ("LaTeX", respondLaTeX) - , ("ConTeXt", respondConTeXt) - , ("Texinfo", respondTexinfo) - , ("reST", respondRST) - , ("MediaWiki", respondMediaWiki) - , ("man", respondMan) - , ("DocBook", respondDocbook) - , ("S5", respondS5) - , ("ODT", respondODT) - , ("RTF", respondRTF) ] - -exportBox :: String -> Params -> Html -exportBox page params | isPage page = - let rev = pRevision params - in gui (urlForPage page) ! [identifier "exportbox"] << - ([ textfield "revision" ! [thestyle "display: none;", value (fromJust rev)] | isJust rev ] ++ - [ select ! [name "format"] << - map ((\f -> option ! [value f] << f) . fst) exportFormats - , submit "export" "Export" ]) -exportBox _ _ = noHtml +exportPage :: String -> Params -> Web Response +exportPage page params = do + let format = pFormat params + mDoc <- pageAsPandoc page params + case mDoc of + Nothing -> error $ "Unable to retrieve page contents." + Just doc -> case lookup format exportFormats of + Nothing -> error $ "Unknown export format: " ++ format + Just writer -> writer page doc rawContents :: String -> Params -> Web (Maybe String) rawContents file params = do @@ -1252,20 +712,6 @@ fs <- getFileStore liftIO $ catch (retrieve fs file rev >>= return . Just) (\e -> if e == NotFound then return Nothing else throwIO e) -{- -removeRawHtmlBlock :: Block -> Block -removeRawHtmlBlock (RawHtml _) = RawHtml "" -removeRawHtmlBlock x = x --} - -readerFor :: PageType -> (String -> Pandoc) -readerFor pt = case pt of - RST -> readRST (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) - Markdown -> readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) - -textToPandoc :: PageType -> String -> Pandoc -textToPandoc pt s = {- processPandoc removeRawHtmlBlock $ -} readerFor pt $ filter (/= '\r') s - pageAsPandoc :: String -> Params -> Web (Maybe Pandoc) pageAsPandoc page params = do pt <- getDefaultPageType @@ -1274,27 +720,4 @@ Nothing -> Nothing Just (Pandoc _ blocks) -> Just $ Pandoc (Meta [Str page] [] []) blocks -exportPage :: String -> Params -> Web Response -exportPage page params = do - let format = pFormat params - mDoc <- pageAsPandoc page params - case mDoc of - Nothing -> error $ "Unable to retrieve page contents." - Just doc -> case lookup format exportFormats of - Nothing -> error $ "Unknown export format: " ++ format - Just writer -> writer page doc - --- | Perform a function in a temporary directory and clean up. -withTempDir :: FilePath -> (FilePath -> IO a) -> IO a -withTempDir baseName = bracket (createTempDir 0 baseName) (removeDirectoryRecursive) - --- | Create a temporary directory with a unique name. -createTempDir :: Integer -> FilePath -> IO FilePath -createTempDir num baseName = do - sysTempDir <- getTemporaryDirectory - let dirName = sysTempDir baseName <.> show num - liftIO $ catch (createDirectory dirName >> return dirName) $ - \e -> if isAlreadyExistsError e - then createTempDir (num + 1) baseName - else ioError e diff --git a/Gitit/Config.hs b/Gitit/Config.hs new file mode 100644 --- /dev/null +++ b/Gitit/Config.hs @@ -0,0 +1,82 @@ +{-# 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 parsing command line options and reading the config file. +-} + +module Gitit.Config ( getConfigFromOpts ) +where +import Gitit.State (Config(..), defaultConfig) +import System.Environment +import System.Exit +import System.IO (stderr, hPutStrLn) +import System.Console.GetOpt +import Control.Monad (liftM, foldM) + +data Opt + = Help + | ConfigFile FilePath + | Port Int + | Debug + | Version + deriving (Eq) + +flags :: [OptDescr Opt] +flags = + [ Option ['h'] ["help"] (NoArg Help) + "Print this help message" + , Option ['v'] ["version"] (NoArg Version) + "Print version information" + , Option ['p'] ["port"] (ReqArg (Port . read) "PORT") + "Specify port" + , Option ['d'] ["debug"] (NoArg Debug) + "Print debugging information on each request" + , Option ['f'] ["config-file"] (ReqArg ConfigFile "FILE") + "Specify configuration file" + ] + +parseArgs :: [String] -> IO [Opt] +parseArgs argv = do + progname <- getProgName + case getOpt Permute flags argv of + (opts,_,[]) -> return opts + (_,_,errs) -> hPutStrLn stderr (concat errs ++ usageInfo (usageHeader progname) flags) >> + exitWith (ExitFailure 1) + +usageHeader :: String -> String +usageHeader progname = "Usage: " ++ progname ++ " [opts...]" + +copyrightMessage :: String +copyrightMessage = "\nCopyright (C) 2008 John MacFarlane\n" ++ + "This is free software; see the source for copying conditions. There is no\n" ++ + "warranty, not even for merchantability or fitness for a particular purpose." + +handleFlag :: Config -> Opt -> IO Config +handleFlag conf opt = do + progname <- getProgName + case opt of + Help -> hPutStrLn stderr (usageInfo (usageHeader progname) flags) >> exitWith ExitSuccess + Version -> hPutStrLn stderr (progname ++ " version " ++ _VERSION ++ copyrightMessage) >> exitWith ExitSuccess + Debug -> return $ conf { debugMode = True } + Port p -> return $ conf { portNumber = p } + ConfigFile f -> liftM read (readFile f) + +getConfigFromOpts :: IO Config +getConfigFromOpts = getArgs >>= parseArgs >>= foldM handleFlag defaultConfig + diff --git a/Gitit/Convert.hs b/Gitit/Convert.hs new file mode 100644 --- /dev/null +++ b/Gitit/Convert.hs @@ -0,0 +1,71 @@ +{- +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 converting markup formats. +-} + +module Gitit.Convert ( textToPandoc + , pandocToHtml + ) +where +import Text.Pandoc +import Gitit.State +import Control.Monad.Trans (MonadIO) +import Text.XHtml +import Text.Pandoc.Shared (HTMLMathMethod(..)) + +{- +removeRawHtmlBlock :: Block -> Block +removeRawHtmlBlock (RawHtml _) = RawHtml "" +removeRawHtmlBlock x = x +-} + +readerFor :: PageType -> (String -> Pandoc) +readerFor pt = case pt of + RST -> readRST (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) + Markdown -> readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) + +textToPandoc :: PageType -> String -> Pandoc +textToPandoc pt s = {- processPandoc removeRawHtmlBlock $ -} readerFor pt $ filter (/= '\r') s + +-- | Convert links with no URL to wikilinks. +convertWikiLinks :: Inline -> Inline +convertWikiLinks (Link ref ("", "")) = + Link ref (refToUrl ref, "Go to wiki page") +convertWikiLinks x = x + +refToUrl :: [Inline] -> String +refToUrl = concatMap go + where go (Str x) = x + go (Space) = "%20" + go (Quoted DoubleQuote xs) = '"' : (refToUrl xs ++ "\"") + go (Quoted SingleQuote xs) = '\'' : (refToUrl xs ++ "'") + go (Apostrophe) = "'" + go (Ellipses) = "..." + go (Math InlineMath t) = '$' : (t ++ "$") + go _ = "" + +-- | Converts pandoc document to HTML. +pandocToHtml :: MonadIO m => Pandoc -> m Html +pandocToHtml pandocContents = do + cfg <- getConfig + return $ writeHtml (defaultWriterOptions { writerStandalone = False + , writerHTMLMathMethod = JsMath (Just "/js/jsMath/easy/load.js") + , writerTableOfContents = tableOfContents cfg + }) $ processPandoc convertWikiLinks pandocContents + diff --git a/Gitit/Export.hs b/Gitit/Export.hs new file mode 100644 --- /dev/null +++ b/Gitit/Export.hs @@ -0,0 +1,99 @@ +{- +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 Gitit.Export ( exportFormats ) +where +import Text.Pandoc +import Text.Pandoc.ODT (saveOpenDocumentAsODT) +import Gitit.Server +import Gitit.Util (withTempDir) +import Gitit.State +import Control.Monad.Trans (liftIO) +import Text.XHtml (noHtml) +import qualified Data.ByteString.Lazy as B +import System.FilePath ((<.>), ()) +import Codec.Binary.UTF8.String (encodeString) + +defaultRespOptions :: WriterOptions +defaultRespOptions = defaultWriterOptions { writerStandalone = True, writerWrapText = True } + +respondLaTeX :: String -> Pandoc -> Web Response +respondLaTeX page = ok . setContentType "application/x-latex" . setFilename (page ++ ".tex") . toResponse . encodeString . + writeLaTeX (defaultRespOptions {writerHeader = defaultLaTeXHeader}) + +respondConTeXt :: String -> Pandoc -> Web Response +respondConTeXt page = ok . setContentType "application/x-context" . setFilename (page ++ ".tex") . toResponse . encodeString . + writeConTeXt (defaultRespOptions {writerHeader = defaultConTeXtHeader}) + +respondRTF :: String -> Pandoc -> Web Response +respondRTF page = ok . setContentType "application/rtf" . setFilename (page ++ ".rtf") . toResponse . encodeString . + writeRTF (defaultRespOptions {writerHeader = defaultRTFHeader}) + +respondRST :: String -> Pandoc -> Web Response +respondRST _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . + writeRST (defaultRespOptions {writerHeader = "", writerReferenceLinks = True}) + +respondMan :: String -> Pandoc -> Web Response +respondMan _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . + writeMan (defaultRespOptions {writerHeader = ""}) + +respondS5 :: String -> Pandoc -> Web Response +respondS5 _ = ok . toResponse . writeS5 (defaultRespOptions {writerHeader = defaultS5Header, + writerS5 = True, writerIncremental = True}) + +respondTexinfo :: String -> Pandoc -> Web Response +respondTexinfo page = ok . setContentType "application/x-texinfo" . setFilename (page ++ ".texi") . toResponse . encodeString . + writeTexinfo (defaultRespOptions {writerHeader = ""}) + +respondDocbook :: String -> Pandoc -> Web Response +respondDocbook page = ok . setContentType "application/docbook+xml" . setFilename (page ++ ".xml") . toResponse . encodeString . + writeDocbook (defaultRespOptions {writerHeader = defaultDocbookHeader}) + +respondMediaWiki :: String -> Pandoc -> Web Response +respondMediaWiki _ = ok . setContentType "text/plain; charset=utf-8" . toResponse . encodeString . + writeMediaWiki (defaultRespOptions {writerHeader = ""}) + +respondODT :: String -> Pandoc -> Web Response +respondODT page doc = do + let openDoc = writeOpenDocument (defaultRespOptions {writerHeader = defaultOpenDocumentHeader}) doc + contents <- liftIO $ withTempDir "gitit-temp-odt" $ \tempdir -> do + let tempfile = tempdir page <.> "odt" + conf <- getConfig + let repoPath = case repository conf of + Git path' -> path' + Darcs path' -> path' + saveOpenDocumentAsODT tempfile repoPath openDoc + B.readFile tempfile + ok $ setContentType "application/vnd.oasis.opendocument.text" $ setFilename (page ++ ".odt") $ (toResponse noHtml) {rsBody = contents} + +exportFormats :: [(String, String -> Pandoc -> Web Response)] -- (description, writer) +exportFormats = [ ("LaTeX", respondLaTeX) + , ("ConTeXt", respondConTeXt) + , ("Texinfo", respondTexinfo) + , ("reST", respondRST) + , ("MediaWiki", respondMediaWiki) + , ("man", respondMan) + , ("DocBook", respondDocbook) + , ("S5", respondS5) + , ("ODT", respondODT) + , ("RTF", respondRTF) ] + + diff --git a/Gitit/Framework.hs b/Gitit/Framework.hs new file mode 100644 --- /dev/null +++ b/Gitit/Framework.hs @@ -0,0 +1,303 @@ +{- +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 +-} + +{- 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 + diff --git a/Gitit/HAppS.hs b/Gitit/HAppS.hs deleted file mode 100644 --- a/Gitit/HAppS.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- -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 --} - -{- Replacements for HAppS functions that don't handle UTF-8 properly. --} - -module Gitit.HAppS - ( look - , lookRead - , lookCookieValue - , mkCookie - ) -where -import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie) -import qualified HAppS.Server (lookCookieValue, mkCookie) -import Text.Pandoc.CharacterReferences (decodeCharacterReferences) -import Control.Monad (liftM) -import Data.ByteString.Lazy.UTF8 (toString) -import Codec.Binary.UTF8.String (encodeString, decodeString) - --- Contents of an HTML text area or text field generated by Text.XHtml --- will often contain decimal character references. We want to convert these --- to regular unicode characters. We also need to use toString to --- convert from UTF-8, since HAppS doesn't do this. - -look :: String -> RqData String -look = liftM (decodeCharacterReferences . toString) . HAppS.Server.lookBS - -lookRead :: Read a => String -> RqData a -lookRead = liftM read . look - -lookCookieValue :: String -> RqData String -lookCookieValue = liftM decodeString . HAppS.Server.lookCookieValue - -mkCookie :: String -> String -> Cookie -mkCookie name = HAppS.Server.mkCookie name . encodeString diff --git a/Gitit/Initialize.hs b/Gitit/Initialize.hs new file mode 100644 --- /dev/null +++ b/Gitit/Initialize.hs @@ -0,0 +1,80 @@ +{- +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 initializing a Gitit wiki. +-} + +module Gitit.Initialize ( createStaticIfMissing, createRepoIfMissing ) +where +import System.FilePath ((), (<.>), takeExtension) +import Data.FileStore +import Gitit.State +import Paths_gitit (getDataFileName) +import qualified Data.ByteString.Lazy as B +import Control.Exception (throwIO, try) +import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, getDirectoryContents) +import System.IO (stderr, hPutStrLn) +import Control.Monad (unless, forM_, liftM) + +-- | Create page repository unless it exists. +createRepoIfMissing :: Config -> IO () +createRepoIfMissing conf = do + fs <- getFileStore + repoExists <- try (initialize fs) >>= \res -> + case res of + Right _ -> return False + Left RepositoryExists -> return True + Left e -> throwIO e >> return False + unless repoExists $ do + welcomepath <- getDataFileName $ "data" "FrontPage.page" + welcomecontents <- B.readFile welcomepath + helppath <- getDataFileName $ "data" "Help.page" + helpcontents <- B.readFile helppath + -- add front page and help page + create fs (frontPage conf <.> "page") (Author "Gitit" "") "Default front page" welcomecontents + create fs "Help.page" (Author "Gitit" "") "Default front page" helpcontents + hPutStrLn stderr "Created repository" + + +-- | Create static directory unless it exists. +createStaticIfMissing :: FilePath -> IO () +createStaticIfMissing staticdir = do + staticExists <- doesDirectoryExist staticdir + unless staticExists $ do + + let cssdir = staticdir "css" + createDirectoryIfMissing True cssdir + cssDataDir <- getDataFileName "css" + cssFiles <- liftM (filter (\f -> takeExtension f == ".css")) $ getDirectoryContents cssDataDir + forM_ cssFiles $ \f -> copyFile (cssDataDir f) (cssdir f) + + let icondir = staticdir "img" "icons" + createDirectoryIfMissing True icondir + iconDataDir <- getDataFileName ("img" "icons") + iconFiles <- liftM (filter (\f -> takeExtension f == ".png")) $ getDirectoryContents iconDataDir + forM_ iconFiles $ \f -> copyFile (iconDataDir f) (icondir f) + + logopath <- getDataFileName $ "img" "gitit-dog.png" + copyFile logopath $ staticdir "img" "logo.png" + + let jsdir = staticdir "js" + createDirectoryIfMissing True jsdir + let javascripts = ["jquery.min.js", "jquery-ui.packed.js", + "folding.js", "dragdiff.js", "preview.js", "search.js", "uploadForm.js"] + jsDataDir <- getDataFileName "js" + forM_ javascripts $ \f -> copyFile (jsDataDir f) (jsdir f) + + hPutStrLn stderr $ "Created " ++ staticdir ++ " directory" + diff --git a/Gitit/Layout.hs b/Gitit/Layout.hs new file mode 100644 --- /dev/null +++ b/Gitit/Layout.hs @@ -0,0 +1,148 @@ +{- +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 and data structures for wiki page layout. +-} + +module Gitit.Layout ( PageLayout(..) + , Tab(..) + , defaultPageLayout + , formattedPage + ) +where +import Data.FileStore +import Gitit.Server +import Gitit.Framework +import Gitit.State +import Gitit.Util (orIfNull) +import Gitit.Export (exportFormats) +import Network.HTTP (urlEncodeVars) +import Codec.Binary.UTF8.String (encodeString) +import qualified Text.StringTemplate as T +import Text.XHtml hiding ( (), dir, method, password, rev ) +import Data.Maybe (isNothing, isJust, mapMaybe, fromJust) +import Data.List (isSuffixOf) +import Prelude hiding (catch) +import Control.Exception (throwIO, catch) +import Control.Monad.Trans (liftIO) + +-- | Abstract representation of page layout (tabs, scripts, etc.) +data PageLayout = PageLayout + { pgTitle :: String + , pgScripts :: [String] + , pgShowPageTools :: Bool + , pgTabs :: [Tab] + , pgSelectedTab :: Tab + } + +data Tab = ViewTab | EditTab | HistoryTab | DiscussTab | DiffTab deriving (Eq, Show) + +defaultPageLayout :: PageLayout +defaultPageLayout = PageLayout + { pgTitle = "" + , pgScripts = [] + , pgShowPageTools = True + , pgTabs = [ViewTab, EditTab, HistoryTab, DiscussTab] + , pgSelectedTab = ViewTab + } + +-- | Returns formatted page +formattedPage :: PageLayout -> String -> Params -> Html -> Web Response +formattedPage layout page params htmlContents = do + let rev = pRevision params + let path' = if isPage page then pathForPage page else page + fs <- getFileStore + sha1 <- case rev of + Nothing -> liftIO $ catch (latest fs path') + (\e -> if e == NotFound + then return "" + else throwIO e) + Just r -> return r + user <- getLoggedInUser params + let javascriptlinks = if null (pgScripts layout) + then "" + else renderHtmlFragment $ concatHtml $ map + (\x -> script ! [src ("/js/" ++ x), thetype "text/javascript"] << noHtml) + (["jquery.min.js", "jquery-ui.packed.js"] ++ pgScripts layout) + let pageTitle = pgTitle layout `orIfNull` page + let tabli tab = if tab == pgSelectedTab layout + then li ! [theclass "selected"] + else li + let origPage s = if ":discuss" `isSuffixOf` s then take (length s - 8) s else s + let linkForTab HistoryTab = Just $ tabli HistoryTab << anchor ! [href $ urlForPage page ++ "?history" ++ + case rev of { Just r -> "&revision" ++ r; Nothing -> "" }] << "history" + linkForTab DiffTab = Just $ tabli DiffTab << anchor ! [href ""] << "diff" + linkForTab ViewTab = if isDiscussPage page + then Just $ tabli DiscussTab << anchor ! [href $ urlForPage $ origPage page] << "page" + else Just $ tabli ViewTab << anchor ! [href $ urlForPage page ++ + case rev of { Just r -> "?revision=" ++ r; Nothing -> "" }] << "view" + linkForTab DiscussTab = if isDiscussPage page + then Just $ tabli ViewTab << anchor ! [href $ urlForPage page] << "discuss" + else if isPage page + then Just $ tabli DiscussTab << anchor ! [href $ urlForPage page ++ "?discuss"] << "discuss" + else Nothing + linkForTab EditTab = if isPage page + then Just $ tabli EditTab << anchor ! [href $ urlForPage page ++ "?edit" ++ + (case rev of + Just r -> "&revision=" ++ r ++ "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ r)] + Nothing -> "")] << + if isNothing rev then "edit" else "revert" + else Nothing + let tabs = ulist ! [theclass "tabs"] << mapMaybe linkForTab (pgTabs layout) + let searchbox = gui ("/_search") ! [identifier "searchform"] << + [ textfield "patterns" + , submit "search" "Search" ] + let gobox = gui ("/_go") ! [identifier "goform"] << + [ textfield "gotopage" + , submit "go" "Go" ] + let messages = pMessages params + let htmlMessages = if null messages + then noHtml + else ulist ! [theclass "messages"] << map (li <<) messages + templ <- queryAppState template + let filledTemp = T.render $ + T.setAttribute "pagetitle" pageTitle $ + T.setAttribute "javascripts" javascriptlinks $ + T.setAttribute "pagename" page $ + (case user of + Just u -> T.setAttribute "user" u + Nothing -> id) $ + (if isPage page then T.setAttribute "ispage" "true" else id) $ + (if pgShowPageTools layout then T.setAttribute "pagetools" "true" else id) $ + (if pPrintable params then T.setAttribute "printable" "true" else id) $ + (if isJust rev then T.setAttribute "nothead" "true" else id) $ + (if isJust rev then T.setAttribute "revision" (fromJust rev) else id) $ + T.setAttribute "sha1" sha1 $ + T.setAttribute "searchbox" (renderHtmlFragment (searchbox +++ gobox)) $ + T.setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ + T.setAttribute "tabs" (renderHtmlFragment tabs) $ + T.setAttribute "messages" (renderHtmlFragment htmlMessages) $ + T.setAttribute "content" (renderHtmlFragment htmlContents) $ + templ + ok $ setContentType "text/html" $ toResponse $ encodeString filledTemp + +exportBox :: String -> Params -> Html +exportBox page params | isPage page = + let rev = pRevision params + in gui (urlForPage page) ! [identifier "exportbox"] << + ([ textfield "revision" ! [thestyle "display: none;", value (fromJust rev)] | isJust rev ] ++ + [ select ! [name "format"] << + map ((\f -> option ! [value f] << f) . fst) exportFormats + , submit "export" "Export" ]) +exportBox _ _ = noHtml + diff --git a/Gitit/MimeTypes.hs b/Gitit/MimeTypes.hs deleted file mode 100644 --- a/Gitit/MimeTypes.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- -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 --} - -{- Mapping from file extensions to mime types. --} - -module Gitit.MimeTypes ( readMimeTypesFile ) -where -import qualified Data.Map as M -import qualified HAppS.Server -import System.IO (stderr, hPutStrLn) - --- | 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 = catch (readFile f >>= return . foldr go M.empty . map words . lines) $ - handleMimeTypesFileNotFound - where go [] m = m -- skip blank lines - go (x:xs) m = foldr (\ext m' -> M.insert ext x m') m xs - handleMimeTypesFileNotFound e = do - hPutStrLn stderr $ "Could not read mime types file: " ++ f - hPutStrLn stderr $ show e - hPutStrLn stderr $ "Using defaults instead." - return HAppS.Server.mimeTypes - diff --git a/Gitit/Server.hs b/Gitit/Server.hs new file mode 100644 --- /dev/null +++ b/Gitit/Server.hs @@ -0,0 +1,218 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- +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 +-} + +{- Re-exports HAppS functions needed by gitit, including + replacements for HAppS functions that don't handle UTF-8 properly, + new functions for setting headers and zipping contents and for looking up IP + addresses, and a fix for broken HAppS cookie parsing. +-} + +module Gitit.Server + ( look + , lookPairs + , lookRead + , mkCookie + , filterIf + , gzipBinary + , acceptsZip + , withExpiresHeaders + , setContentType + , setFilename + , lookupIPAddr + , readMimeTypesFile + , cookieFixer + -- re-exported HAppS functions + , ok + , toResponse + , Response(..) + , Method(..) + , Request(..) + , Input(..) + , HeaderPair(..) + , Web + , ServerPart + , FromData(..) + , waitForTermination + , Conf(..) + , simpleHTTP + , fileServe + , dir + , multi + , seeOther + , withData + , withRequest + , anyRequest + , noHandle + , uriRest + , lookInput + , addCookie + , lookCookieValue + , readCookieValue + ) +where +import HAppS.Server hiding (look, lookRead, lookPairs, mkCookie, getCookies) +import qualified HAppS.Server (mkCookie) +import HAppS.Server.Cookie (Cookie(..)) +import Network.Socket (getAddrInfo, defaultHints, addrAddress) +import System.IO (stderr, hPutStrLn) +import Text.Pandoc.CharacterReferences (decodeCharacterReferences) +import Control.Monad (liftM) +import Control.Monad.Reader +import Data.DateTime +import Data.ByteString.Lazy.UTF8 (toString) +import Codec.Binary.UTF8.String (encodeString) +import qualified Data.ByteString.Char8 as C +import Data.Char (chr, toLower) +import Data.List ((\\)) +import Data.Maybe +import qualified Data.Map as M +import Codec.Compression.GZip (compress) +import Control.Applicative +import Control.Monad (MonadPlus(..), ap) +-- Hide Parsec's definitions of some Applicative functions. +import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), token) + +-- Contents of an HTML text area or text field generated by Text.XHtml +-- will often contain decimal character references. We want to convert these +-- to regular unicode characters. We also need to use toString to +-- convert from UTF-8, since HAppS doesn't do this. + +look :: String -> RqData String +look = liftM (decodeCharacterReferences . toString) . lookBS + +lookPairs :: RqData [(String,String)] +lookPairs = asks fst >>= return . map (\(n,vbs)->(n,toString $ inputValue vbs)) + +lookRead :: Read a => String -> RqData a +lookRead = liftM read . look + +mkCookie :: String -> String -> Cookie +mkCookie name = HAppS.Server.mkCookie name . encodeString + +-- Functions for zipping responses and setting headers. + +filterIf :: (Request -> Bool) -> (Response -> Response) -> ServerPart Response -> ServerPart Response +filterIf test filt sp = + let handler = unServerPartT sp + in withRequest $ \req -> + if test req + then liftM filt $ handler req + else handler req + +gzipBinary :: Response -> Response +gzipBinary r@(Response {rsBody = b}) = setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b} + +acceptsZip :: Request -> Bool +acceptsZip req = isJust $ M.lookup (C.pack "accept-encoding") (rqHeaders req) + +getCacheTime :: IO (Maybe DateTime) +getCacheTime = liftM (Just . addMinutes 360) $ getCurrentTime + +withExpiresHeaders :: ServerPart Response -> ServerPart Response +withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp] + +setContentType :: String -> Response -> Response +setContentType = setHeader "Content-Type" + +setFilename :: String -> Response -> Response +setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\"" + +-- IP lookup + +lookupIPAddr :: String -> IO (Maybe String) +lookupIPAddr hostname = do + addrs <- getAddrInfo (Just defaultHints) (Just hostname) Nothing + if null addrs + then return Nothing + else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ head addrs + + +-- mime types + +-- | 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 = catch (readFile f >>= return . foldr go M.empty . map words . lines) $ + handleMimeTypesFileNotFound + where go [] m = m -- skip blank lines + go (x:xs) m = foldr (\ext m' -> M.insert ext x m') m xs + handleMimeTypesFileNotFound e = do + hPutStrLn stderr $ "Could not read mime types file: " ++ f + hPutStrLn stderr $ show e + hPutStrLn stderr $ "Using defaults instead." + return mimeTypes + +----- the following code is from the HAppSHelpers package, 0.10, +----- (C) 2008 Thomas Hartman. +----- Needed until HAppS Server cookie parsing is fixed. + +instance Applicative (GenParser s a) where + pure = return + (<*>) = ap + +instance Alternative (GenParser s a) where + empty = mzero + (<|>) = mplus + +parseCookiesM :: (Monad m) => String -> m [Cookie] +parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str + +cookiesParser :: GenParser Char st [Cookie] +cookiesParser = av_pairs + where -- Parsers based on RFC 2109 + av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair) + av_pair = cookie <$> attr <*> option "" (char '=' *> value) + attr = spaces *> token + value = word + word = incomp_token <|> quoted_string + + -- Parsers based on RFC 2068 + token = many1 $ oneOf ((chars \\ ctl) \\ tspecials) + quoted_string = char '"' *> many (oneOf qdtext) <* char '"' + + -- Custom parser, incompatible with RFC 2068, but very forgiving ;) + incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";") + + -- Primitives from RFC 2068 + tspecials = "()<>@,;:\\\"/[]?={} \t" + ctl = map chr (127:[0..31]) + chars = map chr [0..127] + octet = map chr [0..255] + text = octet \\ ctl + qdtext = text \\ "\"" + +cookie :: String -> String -> Cookie +cookie key value = Cookie "" "" "" (low key) value + +cookieFixer :: ServerPartT m a -> ServerPartT m a +cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } ) + where + fixedCookies request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ] + +-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from +-- the most specific to the least specific. Multiple cookies with the same +-- name are allowed to exist. +getCookies :: Monad m => C.ByteString -> m [Cookie] +getCookies header | C.null header = return [] + | otherwise = parseCookiesM (C.unpack header) + +low :: String -> String +low = map toLower diff --git a/Gitit/State.hs b/Gitit/State.hs --- a/Gitit/State.hs +++ b/Gitit/State.hs @@ -31,11 +31,10 @@ import Control.Monad (replicateM, liftM) import Control.Exception (try, throwIO) import Data.FileStore -import Gitit.MimeTypes (readMimeTypesFile) import Data.List (intercalate) -import Data.Char (toLower) import Text.XHtml (Html) import qualified Text.StringTemplate as T +import Gitit.Server (readMimeTypesFile) appstate :: IORef AppState appstate = unsafePerformIO $ newIORef $ AppState { sessions = undefined @@ -251,13 +250,6 @@ getFileStore :: MonadIO m => m FileStore getFileStore = queryAppState filestore - -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 getDefaultPageType :: MonadIO m => m PageType getDefaultPageType = liftM defaultPageType (queryAppState config) diff --git a/Gitit/Util.hs b/Gitit/Util.hs new file mode 100644 --- /dev/null +++ b/Gitit/Util.hs @@ -0,0 +1,57 @@ +{- +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 +-} + +{- Utility functions for Gitit. +-} + +module Gitit.Util ( withTempDir + , orIfNull + , consolidateHeads + ) +where +import System.Directory (getTemporaryDirectory, createDirectory, removeDirectoryRecursive) +import Control.Exception (bracket) +import System.FilePath ((), (<.>)) +import System.IO.Error (isAlreadyExistsError) +import Control.Monad.Trans (liftIO) +import Data.List (nub) + +-- | Perform a function in a temporary directory and clean up. +withTempDir :: FilePath -> (FilePath -> IO a) -> IO a +withTempDir baseName = bracket (createTempDir 0 baseName) (removeDirectoryRecursive) + +-- | Create a temporary directory with a unique name. +createTempDir :: Integer -> FilePath -> IO FilePath +createTempDir num baseName = do + sysTempDir <- getTemporaryDirectory + let dirName = sysTempDir baseName <.> show num + liftIO $ catch (createDirectory dirName >> return dirName) $ + \e -> if isAlreadyExistsError e + then createTempDir (num + 1) baseName + else ioError e + +-- | Returns a string, if it is not null, or a backup, if it is. +orIfNull :: String -> String -> String +orIfNull str backup = if null str then backup else str + +-- | Map a list of nonempty lists onto a list of pairs of list heads and list of tails. +-- e.g. [[1,2],[1],[2,1]] -> [(1,[[2],[]]), (2,[[1]])] +consolidateHeads :: Eq a => [[a]] -> [(a,[[a]])] +consolidateHeads lst = + let heads = nub $ map head lst + tailsFor h = map tail [l | l <- lst, head l == h] + in map (\h -> (h, tailsFor h)) heads + + diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -25,7 +25,8 @@ ------------------------------ You'll need the [GHC][] compiler and the [cabal-install][] tool. GHC can -be downloaded [here][]. For [cabal-install][] on *nix, follow the [quick +be downloaded [here][]. Note that, starting with release 0.5, GHC 6.10 +or higher is required. For [cabal-install][] on *nix, follow the [quick install][] instructions. [GHC]: http://www.haskell.org/ghc/ @@ -69,6 +70,9 @@ git --version +You should also make sure that you are using a UTF-8 locale. +(To check this, type `locale`.) + Switch to the directory where you want to run gitit. This should be a directory where you have write access, since two directories, `static` and `wikidata`, and two files, `gitit-users` and `template.html`, will be created here. To @@ -285,7 +289,7 @@ Acknowledgements ================ -Gwern Brandwen helped to optimize Gitit. Simon Michael contributed the patch for +Gwern Branwen helped to optimize Gitit. Simon Michael contributed the patch for RST support. The visual layout is shamelessly borrowed from Wikipedia. diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,5 +1,5 @@ name: gitit -version: 0.5 +version: 0.5.1 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git or darcs, and pandoc. @@ -35,23 +35,33 @@ js/jquery-ui.packed.js, js/preview.js, js/search.js, data/post-update, data/FrontPage.page, data/Help.page, - data/template.html, - README.markdown, data/SampleConfig.hs, BLUETRIP-LICENSE, - TANGOICONS + data/template.html, data/SampleConfig.hs, + CHANGES, README.markdown, BLUETRIP-LICENSE, TANGOICONS +Flag happstack + description: Use Happstack instead of HAppS for the server. + default: False + Executable gitit hs-source-dirs: . main-is: Gitit.hs - other-modules: Gitit.State, Gitit.HAppS, Gitit.MimeTypes, + other-modules: Gitit.State, Gitit.Server, Gitit.Util, Gitit.Export, Gitit.Layout, + Gitit.Convert, Gitit.Initialize, Gitit.Config, Gitit.Framework, Paths_gitit build-depends: base >=3, parsec < 3, pretty, xhtml, containers, pandoc >= 1.1, process, filepath, directory, mtl, cgi, network, old-time, highlighting-kate, bytestring, - utf8-string, HAppS-Server >= 0.9.3 && < 0.9.4, - SHA > 1, HTTP, HStringTemplate, random, network >= 2.1.0.0, - recaptcha >= 0.1, filestore, datetime, zlib + utf8-string, SHA > 1, HTTP, HStringTemplate, random, + network >= 2.1.0.0, recaptcha >= 0.1, filestore, datetime, zlib if impl(ghc >= 6.10) build-depends: base >= 4, syb + if flag(happstack) + build-depends: happstack-server >= 0.1 && < 0.2 + cpp-options: -D_HAPPSTACK + else + build-depends: HAppS-Server >= 0.9.3 && < 0.9.4 + cpp-options: -D_HAPPS ghc-options: -Wall -threaded + cpp-options: -D_VERSION="0.5.1" ghc-prof-options: -auto-all