Permalink
Browse files

Migrated to happstack-6.

API changes:

* Removed withInput.
* Replace fileContents with filePath in Params.

Fixes:

* uploadForm.js:  Remove prefix with path when populating wikiname field.
  • Loading branch information...
1 parent 95f2256 commit c0f4586902d2f19094d20c7c3e8a005e53eb62a9 @jgm committed Apr 21, 2011
View
@@ -125,17 +125,21 @@ import Control.Monad.Reader
import Prelude hiding (readFile)
import qualified Data.ByteString.Char8 as B
import System.FilePath ((</>))
+import System.Directory (getTemporaryDirectory)
import Safe
-- | Happstack handler for a gitit wiki.
wiki :: Config -> ServerPart Response
wiki conf = do
+ tempDir <- liftIO getTemporaryDirectory
+ let maxSize = fromIntegral $ maxUploadSize conf
+ decodeBody $ defaultBodyPolicy tempDir maxSize maxSize maxSize
let static = staticDir conf
defaultStatic <- liftIO $ getDataFileName $ "data" </> "static"
-- if file not found in staticDir, we check also in the data/static
-- directory, which contains defaults
let staticHandler = withExpiresHeaders $
- fileServeStrict' [] static `mplus` fileServeStrict' [] defaultStatic
+ serveDirectory' static `mplus` serveDirectory' defaultStatic
let debugHandler' = msum [debugHandler | debugMode conf]
let handlers = debugHandler' `mplus` authHandler conf `mplus`
authenticate ForRead (msum wikiHandlers)
@@ -146,12 +150,12 @@ wiki conf = do
else return ""
staticHandler `mplus` runHandler ws (withUser conf handlers)
--- | Like 'fileServeStrict', but if file is not found, fail instead of
+-- | Like 'serveDirectory', but if file is not found, fail instead of
-- returning a 404 error.
-fileServeStrict' :: [FilePath] -> FilePath -> ServerPart Response
-fileServeStrict' ps p = do
+serveDirectory' :: FilePath -> ServerPart Response
+serveDirectory' p = do
rq <- askRq
- resp' <- fileServeStrict ps p
+ resp' <- serveDirectory EnableBrowsing [] p
if rsCode resp' == 404 || lastNote "fileServeStrict'" (rqUri rq) == '/'
then mzero -- pass through if not found or directory index
else do
@@ -215,8 +219,6 @@ reloadTemplates = do
runHandler :: WikiState -> Handler -> ServerPart Response
runHandler = mapServerPartT . unpackReaderT
-unpackReaderT:: (Monad m)
- => c
- -> (ReaderT c m) (Maybe ((Either b a), FilterFun b))
- -> m (Maybe ((Either b a), FilterFun b))
-unpackReaderT st handler = runReaderT handler st
+unpackReaderT :: s -> UnWebT (ReaderT s IO) a -> UnWebT IO a
+unpackReaderT st uw = runReaderT uw st
+
@@ -36,7 +36,7 @@ import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import qualified Text.XHtml as X ( password )
import System.Process (readProcessWithExitCode)
-import Control.Monad (unless, liftM)
+import Control.Monad (unless, liftM, mplus)
import Control.Monad.Trans (MonadIO(), liftIO)
import System.Exit
import System.Log.Logger (logM, Priority(..))
@@ -51,7 +51,6 @@ import Network.HTTP (urlEncodeVars, urlDecode, urlEncode)
import Codec.Binary.UTF8.String (encodeString)
import Data.ByteString.UTF8 (toString)
import Network.Gitit.Rpxnow as R
-import Control.Monad.Reader (runReaderT, ask)
data ValidationType = Register
| ResetPassword
@@ -374,7 +373,7 @@ loginUser params = do
if allowed
then do
key <- newSession (SessionData uname)
- addCookie (sessionTimeout cfg) (mkCookie "sid" (show key))
+ addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ uname)
else
withMessages ["Invalid username or password."] loginUserForm
@@ -391,8 +390,7 @@ logoutUser params = do
case key of
Just k -> do
delSession k
- -- make cookie expire immediately, effectively deleting it
- addCookie 0 (mkCookie "sid" "-1")
+ expireCookie "sid"
Nothing -> return ()
seeOther (encUrl dest) $ toResponse "You have been logged out."
@@ -467,22 +465,24 @@ loginRPXUser params = do
user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none"
updateGititState $ \s -> s { users = M.insert userId user (users s) }
key <- newSession (SessionData userId)
- addCookie (sessionTimeout cfg) (mkCookie "sid" (show key))
+ addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
see $ fromJust $ rDestination params
where
prop pname info = lookup pname $ R.userData info
see url = seeOther (encUrl url) $ toResponse noHtml
-- The parameters passed by the RPX callback call.
-data RPars = RPars {rToken::Maybe String,rDestination::Maybe String} deriving Show
+data RPars = RPars { rToken :: Maybe String
+ , rDestination :: Maybe String }
+ deriving Show
instance FromData RPars where
fromData = do
- let look' = liftM urlDecode . look
- env <- ask
- let vtoken = runReaderT (look "token") env
- let vDestination = runReaderT (look' "destination") env
- return RPars {rToken=vtoken,rDestination=vDestination}
+ vtoken <- liftM Just (look "token") `mplus` return Nothing
+ vDestination <- liftM (Just . urlDecode) (look "destination") `mplus`
+ return Nothing
+ return RPars { rToken = vtoken
+ , rDestination = vDestination }
rpxAuthHandlers :: [Handler]
rpxAuthHandlers =
@@ -46,7 +46,6 @@ module Network.Gitit.Framework (
, isSourceCode
-- * Combinators that change the request locally
, withMessages
- , withInput
-- * Miscellaneous
, urlForPage
, pathForPage
@@ -106,7 +105,7 @@ withUserFromSession handler = withData $ \(sk :: Maybe SessionKey) -> do
mbUser <- case mbSd of
Nothing -> return Nothing
Just sd -> do
- addCookie (sessionTimeout cfg) (mkCookie "sid" (show $ fromJust sk)) -- refresh timeout
+ addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show $ fromJust sk)) -- refresh timeout
getUser $! sessionUser sd
let user = maybe "" uUsername mbUser
localRq (setHeader "REMOTE_USER" user) handler
@@ -323,22 +322,18 @@ guardBareBase = do
-- | Runs a server monad in a local context after setting
-- the "messages" request header.
withMessages :: ServerMonad m => [String] -> m a -> m a
-withMessages = withInput "messages" . show
-
--- | Runs a server monad in a local context after setting
--- request header.
-withInput :: ServerMonad m => String -> String -> m a -> m a
-withInput name val handler = do
+withMessages messages handler = do
req <- askRq
- let inps = filter (\(n,_) -> n /= name) $ rqInputs req
- let newInp = (name, Input { inputValue = fromString val
+ let inps = filter (\(n,_) -> n /= "messages") $ rqInputsQuery req
+ let newInp = ("messages", Input {
+ inputValue = Right $ fromString $ show messages
, inputFilename = Nothing
, inputContentType = ContentType {
ctType = "text"
, ctSubtype = "plain"
, ctParameters = [] }
})
- localRq (\rq -> rq{ rqInputs = newInp : inps }) handler
+ localRq (\rq -> rq{ rqInputsQuery = newInp : inps }) handler
-- | Returns a filestore object derived from the
-- repository path and filestore type specified in configuration.
@@ -100,7 +100,7 @@ handleAny = uriRest $ \uri ->
(ok $ setContentType mimetype $
(toResponse noHtml) {rsBody = contents})
-- ugly hack
- Left NotFound -> anyRequest mzero
+ Left NotFound -> mzero
Left e -> error (show e)
debugHandler :: Handler
@@ -184,7 +184,7 @@ uploadForm = withData $ \(params :: Params) -> do
uploadFile :: Handler
uploadFile = withData $ \(params :: Params) -> do
let origPath = pFilename params
- let fileContents = pFileContents params
+ let filePath = pFilePath params
let wikiname = pWikiname params `orIfNull` takeFileName origPath
let logMsg = pLogMsg params
cfg <- getConfig
@@ -212,17 +212,17 @@ uploadFile = withData $ \(params :: Params) -> do
, (not overwrite && exists, "A file named '" ++ wikiname ++
"' already exists in the repository: choose a new name " ++
"or check the box to overwrite the existing file.")
- , (B.length fileContents > fromIntegral (maxUploadSize cfg),
- "File exceeds maximum upload size.")
, (isPageFile wikiname,
"This file extension is reserved for wiki pages.")
]
if null errors
then do
expireCachedFile wikiname `mplus` return ()
+ fileContents <- liftIO $ B.readFile filePath
+ let len = B.length fileContents
liftIO $ save fs wikiname (Author user email) logMsg fileContents
let contents = thediv <<
- [ h2 << ("Uploaded " ++ show (B.length fileContents) ++ " bytes")
+ [ h2 << ("Uploaded " ++ show len ++ " bytes")
, if takeExtension wikiname `elem` imageExtensions
then p << "To add this image to a page, use:" +++
pre << ("![alt text](/" ++ wikiname ++ ")")
@@ -257,11 +257,11 @@ goToPage = withData $ \(params :: Params) -> do
Just m -> seeOther (base' ++ urlForPage m) $
toResponse $ "Redirecting" ++
" to partial match"
- Nothing -> withInput "patterns" gotopage searchResults
+ Nothing -> searchResults
searchResults :: Handler
searchResults = withData $ \(params :: Params) -> do
- let patterns = pPatterns params
+ let patterns = pPatterns params `orIfNull` [pGotoPage params]
fs <- getFileStore
matchLines <- if null patterns
then return []
@@ -482,7 +482,10 @@ getDiff fs file from to = do
pre ! [theclass "diff"] << map diffLineToHtml rawDiff
editPage :: Handler
-editPage = withData $ \(params :: Params) -> do
+editPage = withData editPage'
+
+editPage' :: Params -> Handler
+editPage' params = do
let rev = pRevision params -- if this is set, we're doing a revert
fs <- getFileStore
page <- getPage
@@ -642,9 +645,10 @@ updatePage = withData $ \(params :: Params) -> do
if conflicts
then "Please resolve conflicts and Save."
else "Please review and Save."
- withMessages [mergeMsg] $
- withInput "editedText" mergedText $
- withInput "sha1" (revId mergedWithRev) editPage
+ editPage' $
+ params{ pEditedText = Just mergedText,
+ pSHA1 = revId mergedWithRev,
+ pMessages = [mergeMsg] }
indexPage :: Handler
indexPage = do
@@ -35,7 +35,7 @@ module Network.Gitit.Server
)
where
import Happstack.Server
-import Happstack.Server.Parts (compressedResponseFilter)
+import Happstack.Server.Compression (compressedResponseFilter)
import Network.Socket (getAddrInfo, defaultHints, addrAddress)
import Control.Monad.Reader
import Data.ByteString.UTF8 as U hiding (lines)
@@ -29,13 +29,10 @@ import Control.Monad (liftM)
import System.Log.Logger (Priority(..))
import Text.Pandoc.Definition (Pandoc)
import Text.XHtml (Html)
-import qualified Data.ByteString.Lazy.UTF8 as L (ByteString)
-import qualified Data.ByteString.Lazy as L (empty)
import qualified Data.Map as M
import Data.List (intersect)
import Data.Time (parseTime)
import System.Locale (defaultTimeLocale)
-import Data.Maybe (fromMaybe)
import Data.FileStore.Types
import Network.Gitit.Server
import Text.Pandoc.CharacterReferences (decodeCharacterReferences)
@@ -281,7 +278,7 @@ data Params = Params { pUsername :: String
, pPrintable :: Bool
, pOverwrite :: Bool
, pFilename :: String
- , pFileContents :: L.ByteString
+ , pFilePath :: FilePath
, pConfirm :: Bool
, pSessionKey :: Maybe SessionKey
, pRecaptcha :: Recaptcha
@@ -319,9 +316,10 @@ instance FromData Params where
wn <- look' "wikiname" `mplus` return ""
pr <- (look' "printable" >> return True) `mplus` return False
ow <- liftM (=="yes") (look' "overwrite") `mplus` return False
- fn <- liftM (fromMaybe "" . inputFilename) (lookInput "file")
- `mplus` return ""
- fc <- liftM inputValue (lookInput "file") `mplus` return L.empty
+ fileparams <- liftM Just (lookFile "file") `mplus` return Nothing
+ let (fp, fn) = case fileparams of
+ Just (x,y,_) -> (x,y)
+ Nothing -> ("","")
ac <- look' "accessCode" `mplus` return ""
cn <- (look' "confirm" >> return True) `mplus` return False
sk <- liftM Just (readCookieValue "sid") `mplus` return Nothing
@@ -353,7 +351,7 @@ instance FromData Params where
, pPrintable = pr
, pOverwrite = ow
, pFilename = fn
- , pFileContents = fc
+ , pFilePath = fp
, pAccessCode = ac
, pConfirm = cn
, pSessionKey = sk
@@ -1,3 +1,6 @@
$(document).ready(function(){
- $("#file").change(function () { $("#wikiname").val($(this).val()); });
+ $("#file").change(function () {
+ var fn = $(this).val().replace(/.*\\/,"");
+ $("#wikiname").val(fn);
+ });
});
View
@@ -139,8 +139,8 @@ Executable gitit
filestore >= 0.4.0.2 && < 0.5,
zlib >= 0.5 && < 0.6,
url >= 2.1 && < 2.2,
- happstack-server >= 0.5 && < 0.6,
- happstack-util >= 0.5 && < 0.6,
+ happstack-server >= 6.0 && < 6.1,
+ happstack-util >= 6.0 && < 6.1,
xml >= 1.3.5,
hslogger >= 1 && < 1.2,
ConfigFile >= 1 && < 1.1,
View
@@ -76,7 +76,8 @@ main = do
-- initialize state
initializeGititState conf'
- let serverConf = Conf { validator = Nothing, port = portNumber conf' }
+ let serverConf = Conf { validator = Nothing, port = portNumber conf',
+ timeout = 20, logAccess = Nothing }
-- open the requested interface
sock <- socket AF_INET Stream defaultProtocol

0 comments on commit c0f4586

Please sign in to comment.