Permalink
Browse files

Major reorganization.

Moved mime stuff into Gitit.HAppS, got rid of Gitit.MimeTypes.
Moved more framework code into Gitit.Framework.
Moved server-related stuff into Gitit.HAppS.
  • Loading branch information...
1 parent 980a07b commit e8d5c6521939b1c17a8654e34af6d3d67c9dd5a0 @jgm committed Jan 31, 2009
Showing with 337 additions and 323 deletions.
  1. +42 −253 Gitit.hs
  2. +236 −29 Gitit/Framework.hs
  3. +57 −0 Gitit/HAppS.hs
  4. +0 −39 Gitit/MimeTypes.hs
  5. +1 −1 Gitit/State.hs
  6. +1 −1 gitit.cabal
View
295 Gitit.hs
@@ -20,10 +20,10 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
module Main where
import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie)
-import Gitit.HAppS (look, lookRead, lookCookieValue, mkCookie, cookieFixer)
+import Gitit.HAppS
import Gitit.Util (withTempDir, orIfNull, consolidateHeads)
import Gitit.Initialize (createStaticIfMissing, createRepoIfMissing)
-import Gitit.Framework (Handler, filterIf, gzipBinary, acceptsZip, withExpiresHeaders, setContentType, setFilename)
+import Gitit.Framework
import System.IO.UTF8
import System.IO (stderr)
import Control.Exception (throwIO, catch, try)
@@ -36,10 +36,9 @@ 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.List (intersperse, 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 Codec.Binary.UTF8.String (encodeString)
import qualified Data.Map as M
import Data.Ord (comparing)
import Paths_gitit
@@ -50,10 +49,10 @@ import Text.Pandoc.Shared (HTMLMathMethod(..), substitute)
import Data.Char (isAlphaNum, isAlpha, toLower)
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as B
-import Network.HTTP (urlEncodeVars, urlEncode)
+import Network.HTTP (urlEncodeVars)
import Text.Highlighting.Kate
import qualified Text.StringTemplate as T
-import Data.DateTime (getCurrentTime, addMinutes, parseDateTime, DateTime, formatDateTime)
+import Data.DateTime (getCurrentTime, addMinutes, formatDateTime)
import Network.Socket
import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)
import Data.FileStore
@@ -113,6 +112,23 @@ main = do
putStrLn "Shutdown complete"
+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
+ in do fs <- getFileStore
+ mimetype <- getMimeTypeForExtension (takeExtension path')
+ res <- liftIO $ try $ (retrieve fs path' Nothing :: IO B.ByteString)
+ case res of
+ Right contents -> anyRequest $ ok $ setContentType mimetype $
+ (toResponse noHtml) {rsBody = contents} -- ugly hack
+ Left NotFound -> anyRequest noHandle
+ Left e -> error (show e)
debugHandler :: Handler
debugHandler = do
@@ -123,6 +139,21 @@ debugHandler = do
liftIO $ putStrLn page >> putStrLn (show params)
noHandle
+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 })
+
wikiHandlers :: [Handler]
wikiHandlers = [ handlePath "_index" GET indexPage
, handlePath "_activity" GET showActivity
@@ -142,262 +173,20 @@ wikiHandlers = [ handlePath "_index" GET indexPage
, 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) 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) showPage ]
+ , withCommand "delete" [ handlePage GET $ unlessNoDelete (ifLoggedIn confirmDelete) showPage,
+ handlePage POST $ unlessNoDelete (ifLoggedIn deletePage) showPage ]
, handleSourceCode
, handleAny
, handlePage GET showPage
]
-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...
- }
-
-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
-
-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
- responder path' (params { pReferer = referer,
- pUri = uri,
- pPeer = peer })
- else noHandle ]
- else anyRequest noHandle
-
--- | 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
- in do fs <- getFileStore
- mimetype <- getMimeTypeForExtension (takeExtension path')
- res <- liftIO $ try $ (retrieve fs path' Nothing :: IO B.ByteString)
- case res of
- Right contents -> anyRequest $ ok $ setContentType mimetype $
- (toResponse noHtml) {rsBody = contents} -- ugly hack
- Left NotFound -> anyRequest noHandle
- Left e -> error (show e)
-
-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
-
showRawPage :: String -> Params -> Web Response
showRawPage = showFileAsText . pathForPage
Oops, something went wrong.

0 comments on commit e8d5c65

Please sign in to comment.