gitit 0.5 → 0.5.1
raw patch · 15 files changed
+1170/−760 lines, 15 filesdep +happstack-server
Dependencies added: happstack-server
Files
- CHANGES +13/−0
- Gitit.hs +74/−651
- Gitit/Config.hs +82/−0
- Gitit/Convert.hs +71/−0
- Gitit/Export.hs +99/−0
- Gitit/Framework.hs +303/−0
- Gitit/HAppS.hs +0/−51
- Gitit/Initialize.hs +80/−0
- Gitit/Layout.hs +148/−0
- Gitit/MimeTypes.hs +0/−39
- Gitit/Server.hs +218/−0
- Gitit/State.hs +1/−9
- Gitit/Util.hs +57/−0
- README.markdown +6/−2
- gitit.cabal +18/−8
+ CHANGES view
@@ -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.+
Gitit.hs view
@@ -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 "<!-- raw HTML removed -->"-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
+ Gitit/Config.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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+
+ Gitit/Convert.hs view
@@ -0,0 +1,71 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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 "<!-- raw HTML removed -->"+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+
+ Gitit/Export.hs view
@@ -0,0 +1,99 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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) ]++
+ Gitit/Framework.hs view
@@ -0,0 +1,303 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>+This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.+This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.+You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- General framework for defining wiki actions. +-}++module Gitit.Framework (+ Handler+ , Recaptcha(..)+ , Params(..)+ , Command(..)+ , getLoggedInUser+ , sessionTime+ , unlessNoEdit+ , unlessNoDelete+ , handle+ , handlePage+ , handleText+ , handlePath+ , withCommand+ , uriPath+ , isPage+ , isDiscussPage+ , isSourceCode+ , urlForPage+ , pathForPage+ , withCommands+ , getMimeTypeForExtension+ , ifLoggedIn+ , validate+ )+where+import Gitit.Server+import Gitit.State+import Text.Pandoc.Shared (substitute)+import Control.Monad.Reader (mplus)+import Data.Char (toLower)+import Data.DateTime+import Control.Monad.Trans (MonadIO)+import qualified Data.ByteString.Lazy as B+import qualified Data.Map as M+import Data.ByteString.UTF8 (fromString, toString)+import Data.Maybe (fromMaybe, fromJust)+import Data.List (intersect, intercalate, isSuffixOf)+import System.FilePath ((<.>), takeExtension)+import Codec.Binary.UTF8.String (decodeString, encodeString)+import Text.Highlighting.Kate+import Network.HTTP (urlEncode)++type Handler = ServerPart Response++data Recaptcha = Recaptcha {+ recaptchaChallengeField :: String+ , recaptchaResponseField :: String+ } deriving (Read, Show)++data Params = Params { pUsername :: String+ , pPassword :: String+ , pPassword2 :: String+ , pRevision :: Maybe String+ , pDestination :: String+ , pReferer :: Maybe String+ , pUri :: String+ , pForUser :: String+ , pSince :: Maybe DateTime+ , pRaw :: String+ , pLimit :: Int+ , pPatterns :: [String]+ , pGotoPage :: String+ , pEditedText :: Maybe String+ , pMessages :: [String]+ , pFrom :: Maybe String+ , pTo :: Maybe String+ , pFormat :: String+ , pSHA1 :: String+ , pLogMsg :: String+ , pEmail :: String+ , pFullName :: String+ , pAccessCode :: String+ , pWikiname :: String+ , pPrintable :: Bool+ , pOverwrite :: Bool+ , pFilename :: String+ , pFileContents :: B.ByteString+ , pUser :: String+ , pConfirm :: Bool + , pSessionKey :: Maybe SessionKey+ , pRecaptcha :: Recaptcha+ , pPeer :: String+ } deriving Show++instance FromData Params where+ fromData = do+ un <- look "username" `mplus` return ""+ pw <- look "password" `mplus` return ""+ p2 <- look "password2" `mplus` return ""+ rv <- (look "revision" >>= \s ->+ return (if null s then Nothing else Just s)) `mplus` return Nothing+ fu <- look "forUser" `mplus` return ""+ si <- (look "since" >>= return . parseDateTime "%Y-%m-%d") `mplus` return Nothing -- YYYY-mm-dd format+ ds <- (lookCookieValue "destination") `mplus` return "/"+ ra <- look "raw" `mplus` return ""+ lt <- look "limit" `mplus` return "100"+ pa <- look "patterns" `mplus` return ""+ gt <- look "gotopage" `mplus` return ""+ me <- lookRead "messages" `mplus` return [] + fm <- (look "from" >>= return . Just) `mplus` return Nothing+ to <- (look "to" >>= return . Just) `mplus` return Nothing+ et <- (look "editedText" >>= return . Just . filter (/= '\r')) `mplus` return Nothing+ fo <- look "format" `mplus` return ""+ sh <- look "sha1" `mplus` return ""+ lm <- look "logMsg" `mplus` return ""+ em <- look "email" `mplus` return ""+ na <- look "fullname" `mplus` return ""+ wn <- look "wikiname" `mplus` return ""+ pr <- (look "printable" >> return True) `mplus` return False+ ow <- (look "overwrite" >>= return . (== "yes")) `mplus` return False+ fn <- (lookInput "file" >>= return . fromMaybe "" . inputFilename) `mplus` return ""+ fc <- (lookInput "file" >>= return . inputValue) `mplus` return B.empty+ ac <- look "accessCode" `mplus` return ""+ cn <- (look "confirm" >> return True) `mplus` return False+ sk <- (readCookieValue "sid" >>= return . Just) `mplus` return Nothing+ rc <- look "recaptcha_challenge_field" `mplus` return ""+ rr <- look "recaptcha_response_field" `mplus` return ""+ return $ Params { pUsername = un+ , pPassword = pw+ , pPassword2 = p2+ , pRevision = rv+ , pForUser = fu+ , pSince = si+ , pDestination = ds+ , pReferer = Nothing -- this gets set by handle...+ , pUri = "" -- this gets set by handle...+ , pRaw = ra+ , pLimit = read lt+ , pPatterns = words pa+ , pGotoPage = gt+ , pMessages = me+ , pFrom = fm+ , pTo = to+ , pEditedText = et+ , pFormat = fo + , pSHA1 = sh+ , pLogMsg = lm+ , pEmail = em+ , pFullName = na + , pWikiname = wn+ , pPrintable = pr + , pOverwrite = ow+ , pFilename = fn+ , pFileContents = fc+ , pAccessCode = ac+ , pUser = "" -- this gets set by ifLoggedIn...+ , pConfirm = cn+ , pSessionKey = sk+ , pRecaptcha = Recaptcha { recaptchaChallengeField = rc, recaptchaResponseField = rr }+ , pPeer = "" -- this gets set by handle...+ }++data Command = Command (Maybe String)++instance FromData Command where+ fromData = do+ pairs <- lookPairs+ return $ case map fst pairs `intersect` commandList of+ [] -> Command Nothing+ (c:_) -> Command $ Just c+ where commandList = ["page", "request", "params", "edit", "showraw", "history",+ "export", "diff", "cancel", "update", "delete", "discuss"]++getLoggedInUser :: MonadIO m => Params -> m (Maybe String)+getLoggedInUser params = do+ mbSd <- maybe (return Nothing) getSession $ pSessionKey params+ let user = case mbSd of+ Nothing -> Nothing+ Just sd -> Just $ sessionUser sd+ return $! user++sessionTime :: Int+sessionTime = 60 * 60 -- session will expire 1 hour after page request++unlessNoEdit :: (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+unlessNoEdit responder fallback =+ \page params -> do cfg <- getConfig+ if page `elem` noEdit cfg+ then fallback page params{pMessages = ("Page is locked." : pMessages params)}+ else responder page params++unlessNoDelete :: (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+unlessNoDelete responder fallback =+ \page params -> do cfg <- getConfig+ if page `elem` noDelete cfg+ then fallback page params{pMessages = ("Page cannot be deleted." : pMessages params)}+ else responder page params++handle :: (String -> Bool) -> Method -> (String -> Params -> Web Response) -> Handler+handle pathtest meth responder = uriRest $ \uri ->+ let path' = decodeString $ uriPath uri+ in if pathtest path'+ then withData $ \params ->+ [ withRequest $ \req ->+ if rqMethod req == meth+ then do+ let referer = case M.lookup (fromString "referer") (rqHeaders req) of+ Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r+ _ -> Nothing+ let peer = fst $ rqPeer req+ responder path' (params { pReferer = referer,+ pUri = uri,+ pPeer = peer })+ else noHandle ]+ else anyRequest noHandle++handlePage :: Method -> (String -> Params -> Web Response) -> Handler+handlePage = handle isPage++handleText :: Method -> (String -> Params -> Web Response) -> Handler+handleText = handle (\x -> isPage x || isSourceCode x)++handlePath :: String -> Method -> (String -> Params -> Web Response) -> Handler+handlePath path' = handle (== path')++withCommand :: String -> [Handler] -> Handler+withCommand command handlers =+ withData $ \com -> case com of+ Command (Just c) | c == command -> handlers+ _ -> []++-- | Returns path portion of URI, without initial /.+-- Consecutive spaces are collapsed. We don't want to distinguish 'Hi There' and 'Hi There'.+uriPath :: String -> String+uriPath = unwords . words . drop 1 . takeWhile (/='?')++isPage :: String -> Bool+isPage ('_':_) = False+isPage s = '.' `notElem` s++isDiscussPage :: String -> Bool+isDiscussPage s = isPage s && ":discuss" `isSuffixOf` s++isSourceCode :: String -> Bool+isSourceCode = not . null . languagesByExtension . takeExtension++urlForPage :: String -> String+urlForPage page = '/' : (substitute "%2f" "/" $ urlEncode $ encodeString page)+-- this is needed so that browsers recognize relative URLs correctly++pathForPage :: String -> FilePath+pathForPage page = page <.> "page"++withCommands :: Method -> [String] -> (String -> Request -> Web Response) -> Handler+withCommands meth commands page = withRequest $ \req -> do+ if rqMethod req /= meth+ then noHandle+ else if all (`elem` (map fst $ rqInputs req)) commands+ then page (intercalate "/" $ rqPaths req) req+ else noHandle++getMimeTypeForExtension :: MonadIO m => String -> m String+getMimeTypeForExtension ext = do+ mimes <- queryAppState mimeMap+ return $ case M.lookup (dropWhile (=='.') $ map toLower ext) mimes of+ Nothing -> "application/octet-stream"+ Just t -> t++ifLoggedIn :: (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+ -> (String -> Params -> Web Response)+ifLoggedIn responder fallback =+ \page params -> do user <- getLoggedInUser params+ case user of+ Nothing -> do+ fallback page (params { pReferer = Just $ pUri params })+ Just u -> do+ usrs <- queryAppState users+ let e = case M.lookup u usrs of+ Just usr -> uEmail usr+ Nothing -> error $ "User '" ++ u ++ "' not found."+ -- give the user another hour...+ addCookie sessionTime (mkCookie "sid" (show $ fromJust $ pSessionKey params))+ responder page (params { pUser = u, pEmail = e })++validate :: [(Bool, String)] -- ^ list of conditions and error messages+ -> [String] -- ^ list of error messages+validate = foldl go []+ where go errs (condition, msg) = if condition then msg:errs else errs+
− Gitit/HAppS.hs
@@ -1,51 +0,0 @@-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or-(at your option) any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- 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
+ Gitit/Initialize.hs view
@@ -0,0 +1,80 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>+This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.+This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.+You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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"+
+ Gitit/Layout.hs view
@@ -0,0 +1,148 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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+
− Gitit/MimeTypes.hs
@@ -1,39 +0,0 @@-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>-This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or-(at your option) any later version.-This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-GNU General Public License for more details.-You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- 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-
+ Gitit/Server.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-+Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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
Gitit/State.hs view
@@ -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)
+ Gitit/Util.hs view
@@ -0,0 +1,57 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>+This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.+This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.+You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- 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++
README.markdown view
@@ -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.
gitit.cabal view
@@ -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