diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -40,11 +40,9 @@ import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf) import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) import Data.ByteString.UTF8 (fromString, toString) -import qualified Data.ByteString.Lazy.UTF8 as L (fromString) import Codec.Binary.UTF8.String (decodeString, encodeString) import qualified Data.Map as M import Data.Ord (comparing) -import Data.Digest.Pure.SHA (sha512, showDigest) import Paths_gitit import Text.Pandoc import Text.Pandoc.ODT (saveOpenDocumentAsODT) @@ -61,9 +59,11 @@ import Gitit.HStringTemplate (setAttribute) import Data.IORef import System.IO.Unsafe (unsafePerformIO) +import Network.Socket +import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) gititVersion :: String -gititVersion = "0.3.4.2" +gititVersion = "0.4.1" sessionTime :: Int sessionTime = 60 * 60 -- session will expire 1 hour after page request @@ -223,8 +223,11 @@ debugHandlers :: [Handler] -debugHandlers = [ withCommand "debug" [ handlePage GET $ \page params -> ok (toResponse $ show (page, params)), - handlePage POST $ \page params -> ok (toResponse $ show (page, params)) ] ] +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 @@ -257,6 +260,11 @@ , handlePage GET showPage ] +data Recaptcha = Recaptcha { + recaptchaChallengeField :: String + , recaptchaResponseField :: String + } deriving (Read, Show) + data Params = Params { pUsername :: String , pPassword :: String , pPassword2 :: String @@ -287,6 +295,8 @@ , pUser :: String , pConfirm :: Bool , pSessionKey :: Maybe SessionKey + , pRecaptcha :: Recaptcha + , pIPAddress :: String } deriving Show instance FromData Params where @@ -318,6 +328,8 @@ 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 @@ -348,6 +360,8 @@ , 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) @@ -361,7 +375,7 @@ data Command = Command (Maybe String) commandList :: [String] -commandList = ["debug", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"] +commandList = ["page", "request", "params", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"] instance FromData Command where fromData = do @@ -406,13 +420,27 @@ then withData $ \params -> [ withRequest $ \req -> if rqMethod req == meth - then let referer = case M.lookup (fromString "referer") (rqHeaders req) of - Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r - _ -> Nothing - in responder path' (params { pReferer = referer, pUri = uri }) + 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 @@ -968,9 +996,7 @@ let uname = pUsername params let pword = pPassword params let destination = pDestination params - cfg <- query GetConfig - let passwordHash = showDigest $ sha512 $ L.fromString $ passwordSalt cfg ++ pword - allowed <- query $ AuthUser uname passwordHash + allowed <- query $ AuthUser uname pword if allowed then do key <- update $ NewSession (SessionData uname) @@ -998,6 +1024,9 @@ Nothing -> noHtml Just (prompt, _) -> label << prompt +++ br +++ X.password "accessCode" ! [size "15"] +++ br + let captcha = if useRecaptcha cfg + then captchaFields (recaptchaPublicKey cfg) Nothing + else noHtml return $ gui "" ! [identifier "loginForm"] << fieldset << [ accessQ , label << "Username (at least 3 letters or digits):", br @@ -1008,6 +1037,7 @@ , label << "Password (at least 6 characters, including at least one non-letter):", br , X.password "password" ! [size "20"], stringToHtml " ", br , label << "Confirm Password:", br, X.password "password2" ! [size "20"], stringToHtml " ", br + , captcha , submit "register" "Register" ] registerUserForm :: String -> Params -> Web Response @@ -1018,8 +1048,6 @@ registerUser :: String -> Params -> Web Response registerUser _ params = do - let page = "_register" - regForm <- registerForm let isValidUsername u = length u >= 3 && all isAlphaNum u let isValidPassword pw = length pw >= 6 && not (all isAlpha pw) let accessCode = pAccessCode params @@ -1028,26 +1056,38 @@ let pword2 = pPassword2 params let email = pEmail params let fakeField = pFullName params + let recaptcha = pRecaptcha params taken <- query $ IsUser uname cfg <- query GetConfig let isValidAccessCode = case accessQuestion cfg of Nothing -> True Just (_, answers) -> accessCode `elem` answers let isValidEmail e = length (filter (=='@') e) == 1 + 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 return $ Right () + let (validCaptcha, captchaError) = case captchaResult of + Right () -> (True, Nothing) + Left err -> (False, Just err) let errors = validate [ (taken, "Sorry, that username is already taken.") , (not isValidAccessCode, "Incorrect response to access prompt.") , (not (isValidUsername uname), "Username must be at least 3 charcaters, all letters or digits.") , (not (isValidPassword pword), "Password must be at least 6 characters, with at least one non-letter.") , (not (null email) && not (isValidEmail email), "Email address appears invalid.") , (pword /= pword2, "Password does not match confirmation.") + , (not validCaptcha, "Failed CAPTCHA (" ++ fromJust captchaError ++ "). Are you really human?") , (not (null fakeField), "You do not seem human enough.") ] -- fakeField is hidden in CSS (honeypot) if null errors then do - let passwordHash = showDigest $ sha512 $ L.fromString $ passwordSalt cfg ++ pword - update $ AddUser uname (User { uUsername = uname, uPassword = passwordHash, uEmail = email }) + user <- liftIO $ mkUser uname email pword + update $ AddUser uname user loginUser "/" (params { pUsername = uname, pPassword = pword, pEmail = email }) - else formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) - page (params { pMessages = errors }) regForm + else registerForm >>= + formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) + "_register" (params { pMessages = errors }) showHighlightedSource :: String -> Params -> Web Response showHighlightedSource file params = do diff --git a/Gitit/State.hs b/Gitit/State.hs --- a/Gitit/State.hs +++ b/Gitit/State.hs @@ -22,7 +22,8 @@ {- Functions for maintaining user list and session state. Parts of this code are based on http://hpaste.org/5957 mightybyte rev by - dbpatterson -} + dbpatterson. +-} module Gitit.State where @@ -33,41 +34,48 @@ import HAppS.State import HAppS.Data import GHC.Conc (STM) +import System.Random (randomRIO) +import Data.Digest.Pure.SHA (sha512, showDigest) +import qualified Data.ByteString.Lazy.UTF8 as L (fromString) -- | Data structure for information read from config file. data Config = Config { - repositoryPath :: FilePath, -- path of git repository for pages - userFile :: FilePath, -- path of users database - templateFile :: FilePath, -- path of page template file - staticDir :: FilePath, -- path of static directory - tableOfContents :: Bool, -- should each page have an automatic table of contents? - maxUploadSize :: Integer, -- maximum size of pages and file uploads - portNumber :: Int, -- port number to serve content on - passwordSalt :: String, -- text to serve as salt in encrypting passwords - debugMode :: Bool, -- should debug info be printed to the console? - frontPage :: String, -- the front page of the wiki - noEdit :: [String], -- pages that cannot be edited through the web interface - noDelete :: [String], -- pages that cannot be deleted through the web interface - accessQuestion :: Maybe (String, [String]) -- if Nothing, then anyone can register for an account. - -- if Just (prompt, answers), then a user will be given the prompt - -- and must give one of the answers in order to register. + repositoryPath :: FilePath, -- path of git repository for pages + userFile :: FilePath, -- path of users database + templateFile :: FilePath, -- path of page template file + staticDir :: FilePath, -- path of static directory + tableOfContents :: Bool, -- should each page have an automatic table of contents? + maxUploadSize :: Integer, -- maximum size of pages and file uploads + portNumber :: Int, -- port number to serve content on + debugMode :: Bool, -- should debug info be printed to the console? + frontPage :: String, -- the front page of the wiki + noEdit :: [String], -- pages that cannot be edited through the web interface + noDelete :: [String], -- pages that cannot be deleted through the web interface + accessQuestion :: Maybe (String, [String]), -- if Nothing, then anyone can register for an account. + -- if Just (prompt, answers), then a user will be given the prompt + -- and must give one of the answers in order to register. + useRecaptcha :: Bool, -- use ReCAPTCHA service to provide captchas for user registration. + recaptchaPublicKey :: String, + recaptchaPrivateKey :: String } deriving (Read, Show,Eq,Typeable,Data) defaultConfig :: Config defaultConfig = Config { - repositoryPath = "wikidata", - userFile = "gitit-users", - templateFile = "template.html", - staticDir = "static", - tableOfContents = True, - maxUploadSize = 100000, - portNumber = 5001, - passwordSalt = "l91snthoae8eou2340987", - debugMode = False, - frontPage = "Front Page", - noEdit = ["Help"], - noDelete = ["Help", "Front Page"], - accessQuestion = Nothing + repositoryPath = "wikidata", + userFile = "gitit-users", + templateFile = "template.html", + staticDir = "static", + tableOfContents = True, + maxUploadSize = 100000, + portNumber = 5001, + debugMode = False, + frontPage = "Front Page", + noEdit = ["Help"], + noDelete = ["Help", "Front Page"], + accessQuestion = Nothing, + useRecaptcha = False, + recaptchaPublicKey = "", + recaptchaPrivateKey = "" } type SessionKey = Integer @@ -79,9 +87,13 @@ data Sessions a = Sessions {unsession::M.Map SessionKey a} deriving (Read,Show,Eq,Typeable,Data) +-- Password salt hashedPassword +data Password = Password { pSalt :: String, pHashed :: String } + deriving (Read,Show,Eq,Typeable,Data) + data User = User { uUsername :: String, - uPassword :: String, -- password stored as SHA512 hash + uPassword :: Password, uEmail :: String } deriving (Show,Read,Typeable,Data) @@ -101,7 +113,9 @@ instance Version AppState instance Version User +instance Version Password +$(deriveSerialize ''Password) $(deriveSerialize ''User) $(deriveSerialize ''AppState) @@ -127,6 +141,23 @@ isUser :: MonadReader AppState m => String -> m Bool isUser name = liftM (M.member name) askUsers +mkUser :: String -- username + -> String -- email + -> String -- unhashed password + -> IO User +mkUser uname email pass = do + salt <- genSalt + return $ User { uUsername = uname, + uPassword = Password { pSalt = salt, pHashed = hashPassword salt pass }, + uEmail = email } + +genSalt :: IO String +genSalt = + replicateM 32 $ randomRIO ('0','z') + +hashPassword :: String -> String -> String +hashPassword salt pass = showDigest $ sha512 $ L.fromString $ salt ++ pass + addUser :: MonadState AppState m => String -> User -> m () addUser name u = modUsers $ M.insert name u @@ -137,7 +168,10 @@ authUser name pass = do users' <- askUsers case M.lookup name users' of - Just u -> return $ pass == uPassword u + Just u -> do + let salt = pSalt $ uPassword u + let hashed = pHashed $ uPassword u + return $ hashed == hashPassword salt pass Nothing -> return False listUsers :: MonadReader AppState m => m [String] diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -93,19 +93,21 @@ option `-f [filename]`. A configuration file takes the following form: Config { - repositoryPath = "wikidata", - userFile = "gitit-users", - templateFile = "template.html", - staticDir = "static", - tableOfContents = False, - maxUploadSize = 100000, - portNumber = 5001, - passwordSalt = "l91snthoae8eou2340987", - debugMode = True, - frontPage = "Front Page", - noEdit = ["Help", "Front Page"], - noDelete = ["Help", "Front Page"], - accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]) + repositoryPath = "wikidata", + userFile = "gitit-users", + templateFile = "template.html", + staticDir = "static", + tableOfContents = False, + maxUploadSize = 100000, + portNumber = 5001, + debugMode = True, + frontPage = "Front Page", + noEdit = ["Help", "Front Page"], + noDelete = ["Help", "Front Page"], + accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]), + useRecaptcha = False, + recaptchaPublicKey = "", + recaptchaPrivateKey = "" } - `repositoryPath` is the (relative) path of the git repository in which @@ -133,10 +135,6 @@ - `portNumber` is the number of the port on which the wiki will be served. -- `passwordSalt` is used to hash the passwords in the user database; - you should change this to something unique if you use gitit in a - production setting. - - `debugMode` is either `True` or `False`. If it is `True`, debug information will be printed to the console when gitit is running. @@ -153,6 +151,16 @@ that will be displayed when a user tries to create an account, and `answer1, answer2, ...` are the valid responses. The user must provide a valid response in order to create an account. + +- `useRecaptcha` is either `True` or `False`. It specifies whether to + use the [reCAPTCHA] service to provide captchas for user registration. + +- `recaptchaPublicKey` and `recaptchaPrivateKey` are + [reCAPTCHA] keys, which can be obtained free of charge at + . The values of these fields are ignored + if `useRecaptcha` is set to `False`. + +[reCAPTCHA]: http://recaptcha.net Configuring gitit ================= diff --git a/data/SampleConfig.hs b/data/SampleConfig.hs --- a/data/SampleConfig.hs +++ b/data/SampleConfig.hs @@ -1,16 +1,18 @@ Config { -repositoryPath = "wikidata", -userFile = "gitit-users", -templateFile = "template.html", -staticDir = "static", -tableOfContents = False, -maxUploadSize = 100000, -portNumber = 5001, -passwordSalt = "l91snthoae8eou2340987", -debugMode = True, -frontPage = "Front Page", -noEdit = ["Help", "Front Page"], -noDelete = ["Help", "Front Page"], -accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]) +repositoryPath = "wikidata", +userFile = "gitit-users", +templateFile = "template.html", +staticDir = "static", +tableOfContents = False, +maxUploadSize = 100000, +portNumber = 5001, +debugMode = True, +frontPage = "Front Page", +noEdit = ["Help", "Front Page"], +noDelete = ["Help", "Front Page"], +accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]), +useRecaptcha = False, +recaptchaPublicKey = "", +recaptchaPrivateKey = "" } diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,5 +1,5 @@ name: gitit -version: 0.3.4.2 +version: 0.4.1 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc. @@ -50,7 +50,7 @@ utf8-string, HAppS-Server >= 0.9.3 && < 0.9.4, HAppS-State >= 0.9.3 && < 0.9.4, HAppS-Data >= 0.9.3 && < 0.9.4, SHA > 1, HTTP, - HStringTemplate + HStringTemplate, random, network >= 2.1.0.0, recaptcha >= 0.1 if impl(ghc >= 6.10) build-depends: base >= 4, syb ghc-options: -Wall -threaded