{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving #-} {- Copyright (C) 2009 John MacFarlane , Henry Laxen 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 -} {- Handlers for registering and authenticating users. -} module Network.Gitit.Authentication ( loginUserForm , formAuthHandlers , httpAuthHandlers , rpxAuthHandlers) where import Network.Gitit.State import Network.Gitit.Types import Network.Gitit.Framework import Network.Gitit.Layout import Network.Gitit.Server import Network.Gitit.Util 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, mplus) import Control.Monad.Trans (MonadIO(), liftIO) import System.Exit import System.Log.Logger (logM, Priority(..)) import Data.Char (isAlphaNum, isAlpha, isAscii) import qualified Data.Map as M import Text.Pandoc.Shared (substitute) import Data.Maybe (isJust, fromJust, isNothing, fromMaybe) import Network.URL (encString, exportURL, add_param, importURL) import Network.BSD (getHostName) import qualified Text.StringTemplate as T import Network.HTTP (urlEncodeVars, urlDecode, urlEncode) import Codec.Binary.UTF8.String (encodeString) import Data.ByteString.UTF8 (toString) import Network.Gitit.Rpxnow as R data ValidationType = Register | ResetPassword deriving (Show,Read) registerUser :: Params -> Handler registerUser params = do result' <- sharedValidation Register params case result' of Left errors -> registerForm >>= formattedPage defaultPageLayout{ pgMessages = errors, pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" } Right (uname, email, pword) -> do user <- liftIO $ mkUser uname email pword addUser uname user loginUser params{ pUsername = uname, pPassword = pword, pEmail = email } resetPasswordRequestForm :: Params -> Handler resetPasswordRequestForm _ = do let passwordForm = gui "" ! [identifier "resetPassword"] << fieldset << [ label << "Username: " , textfield "username" ! [size "20", intAttr "tabindex" 1], stringToHtml " " , submit "resetPassword" "Reset Password" ! [intAttr "tabindex" 2]] cfg <- getConfig let contents = if null (mailCommand cfg) then p << "Sorry, password reset not available." else passwordForm formattedPage defaultPageLayout{ pgShowPageTools = False, pgTabs = [], pgTitle = "Reset your password" } contents resetPasswordRequest :: Params -> Handler resetPasswordRequest params = do let uname = pUsername params mbUser <- getUser uname let errors = case mbUser of Nothing -> ["Unknown user. Please re-register " ++ "or press the Back button to try again."] Just u -> ["Since you did not register with " ++ "an email address, we can't reset your password." | null (uEmail u) ] if null errors then do let response = p << [ stringToHtml "An email has been sent to " , bold $ stringToHtml . uEmail $ fromJust mbUser , br , stringToHtml "Please click on the enclosed link to reset your password." ] sendReregisterEmail (fromJust mbUser) formattedPage defaultPageLayout{ pgShowPageTools = False, pgTabs = [], pgTitle = "Resetting your password" } response else registerForm >>= formattedPage defaultPageLayout{ pgMessages = errors, pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" } resetLink :: String -> User -> String resetLink base' user = exportURL $ foldl add_param (fromJust . importURL $ base' ++ "/_doResetPassword") [("username", uUsername user), ("reset_code", take 20 (pHashed (uPassword user)))] sendReregisterEmail :: User -> GititServerPart () sendReregisterEmail user = do cfg <- getConfig hostname <- liftIO getHostName base' <- getWikiBase let messageTemplate = T.newSTMP $ resetPasswordMessage cfg let filledTemplate = T.render . T.setAttribute "username" (uUsername user) . T.setAttribute "useremail" (uEmail user) . T.setAttribute "hostname" hostname . T.setAttribute "port" (show $ portNumber cfg) . T.setAttribute "resetlink" (resetLink base' user) $ messageTemplate let (mailcommand:args) = words $ substitute "%s" (uEmail user) (mailCommand cfg) (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args filledTemplate liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user ++ " at " ++ uEmail user unless (exitCode == ExitSuccess) $ liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ pErr validateReset :: Params -> (User -> Handler) -> Handler validateReset params postValidate = do let uname = pUsername params user <- getUser uname let knownUser = isJust user let resetCodeMatches = take 20 (pHashed (uPassword (fromJust user))) == pResetCode params let errors = case (knownUser, resetCodeMatches) of (True, True) -> [] (True, False) -> ["Your reset code is invalid"] (False, _) -> ["User " ++ uname ++ " is not known"] if null errors then postValidate (fromJust user) else registerForm >>= formattedPage defaultPageLayout{ pgMessages = errors, pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" } resetPassword :: Params -> Handler resetPassword params = validateReset params $ \user -> resetPasswordForm (Just user) >>= formattedPage defaultPageLayout{ pgShowPageTools = False, pgTabs = [], pgTitle = "Reset your registration info" } doResetPassword :: Params -> Handler doResetPassword params = validateReset params $ \user -> do result' <- sharedValidation ResetPassword params case result' of Left errors -> resetPasswordForm (Just user) >>= formattedPage defaultPageLayout{ pgMessages = errors, pgShowPageTools = False, pgTabs = [], pgTitle = "Reset your registration info" } Right (uname, email, pword) -> do user' <- liftIO $ mkUser uname email pword adjustUser uname user' liftIO $ logM "gitit" WARNING $ "Successfully reset password and email for " ++ uUsername user' loginUser params{ pUsername = uname, pPassword = pword, pEmail = email } registerForm :: GititServerPart Html registerForm = sharedForm Nothing resetPasswordForm :: Maybe User -> GititServerPart Html resetPasswordForm = sharedForm -- synonym for now sharedForm :: Maybe User -> GititServerPart Html sharedForm mbUser = withData $ \params -> do cfg <- getConfig dest <- case pDestination params of "" -> getReferer x -> return x let accessQ = case accessQuestion cfg of Nothing -> noHtml Just (prompt, _) -> label << prompt +++ br +++ X.password "accessCode" ! [size "15", intAttr "tabindex" 1] +++ br let captcha = if useRecaptcha cfg then captchaFields (recaptchaPublicKey cfg) Nothing else noHtml let initField field = case mbUser of Nothing -> "" Just user -> field user let userNameField = case mbUser of Nothing -> label << "Username (at least 3 letters or digits):" +++ br +++ textfield "username" ! [size "20", intAttr "tabindex" 2] +++ br Just user -> label << ("Username (cannot be changed): " ++ uUsername user) +++ br let submitField = case mbUser of Nothing -> submit "register" "Register" Just _ -> submit "resetPassword" "Reset Password" return $ gui "" ! [identifier "loginForm"] << fieldset << [ accessQ , userNameField , label << "Email (optional, will not be displayed on the Wiki):" , br , textfield "email" ! [size "20", intAttr "tabindex" 3, value (initField uEmail)], br , textfield "full_name_1" ! [size "20", theclass "req"] , label << ("Password (at least 6 characters," ++ " including at least one non-letter):") , br , X.password "password" ! [size "20", intAttr "tabindex" 4] , stringToHtml " " , br , label << "Confirm Password:" , br , X.password "password2" ! [size "20", intAttr "tabindex" 5] , stringToHtml " " , br , captcha , textfield "destination" ! [thestyle "display: none;", value dest] , submitField ! [intAttr "tabindex" 6]] sharedValidation :: ValidationType -> Params -> GititServerPart (Either [String] (String,String,String)) sharedValidation validationType params = do let isValidUsername u = length u >= 3 && all isAlphaNum u let isValidPassword pw = length pw >= 6 && not (all isAlpha pw) let accessCode = pAccessCode params let uname = pUsername params let pword = pPassword params let pword2 = pPassword2 params let email = pEmail params let fakeField = pFullName params let recaptcha = pRecaptcha params taken <- isUser uname cfg <- getConfig let optionalTests Register = [(taken, "Sorry, that username is already taken.")] optionalTests ResetPassword = [] let isValidAccessCode = case accessQuestion cfg of Nothing -> True Just (_, answers) -> accessCode `elem` answers let isValidEmail e = length (filter (=='@') e) == 1 peer <- liftM (fst . rqPeer) askRq captchaResult <- if useRecaptcha cfg then if null (recaptchaChallengeField recaptcha) || null (recaptchaResponseField recaptcha) -- no need to bother captcha.net in this case then return $ Left "missing-challenge-or-response" else liftIO $ do mbIPaddr <- lookupIPAddr peer let ipaddr = case mbIPaddr of Just ip -> ip Nothing -> error $ "Could not find ip address for " ++ peer ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg) ipaddr (recaptchaChallengeField recaptcha) (recaptchaResponseField recaptcha) else return $ Right () let (validCaptcha, captchaError) = case captchaResult of Right () -> (True, Nothing) Left err -> (False, Just err) let errors = validate $ optionalTests validationType ++ [ (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, " ++ "and must contain 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), -- fakeField is hidden in CSS (honeypot) "You do not seem human enough. If you're sure you are human, " ++ "try turning off form auto-completion in your browser.") ] return $ if null errors then Right (uname, email, pword) else Left errors -- user authentication loginForm :: String -> GititServerPart Html loginForm dest = do cfg <- getConfig base' <- getWikiBase return $ gui (base' ++ "/_login") ! [identifier "loginForm"] << fieldset << [ label << "Username " , textfield "username" ! [size "15", intAttr "tabindex" 1] , stringToHtml " " , label << "Password " , X.password "password" ! [size "15", intAttr "tabindex" 2] , stringToHtml " " , textfield "destination" ! [thestyle "display: none;", value dest] , submit "login" "Login" ! [intAttr "tabindex" 3] ] +++ p << [ stringToHtml "If you do not have an account, " , anchor ! [href $ base' ++ "/_register?" ++ urlEncodeVars [("destination", encodeString dest)]] << "click here to get one." ] +++ if null (mailCommand cfg) then noHtml else p << [ stringToHtml "If you forgot your password, " , anchor ! [href $ base' ++ "/_resetPassword"] << "click here to get a new one." ] loginUserForm :: Handler loginUserForm = withData $ \params -> do dest <- case pDestination params of "" -> getReferer x -> return x loginForm dest >>= formattedPage defaultPageLayout{ pgShowPageTools = False, pgTabs = [], pgTitle = "Login", pgMessages = pMessages params } loginUser :: Params -> Handler loginUser params = do let uname = pUsername params let pword = pPassword params let destination = pDestination params allowed <- authUser uname pword cfg <- getConfig if allowed then do key <- newSession (SessionData uname) addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ uname) else withMessages ["Invalid username or password."] loginUserForm encUrl :: String -> String encUrl = encString True isAscii logoutUser :: Params -> Handler logoutUser params = do let key = pSessionKey params dest <- case pDestination params of "" -> getReferer x -> return x case key of Just k -> do delSession k expireCookie "sid" Nothing -> return () seeOther (encUrl dest) $ toResponse "You have been logged out." registerUserForm :: Handler registerUserForm = registerForm >>= formattedPage defaultPageLayout{ pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" } formAuthHandlers :: [Handler] formAuthHandlers = [ dir "_register" $ methodSP GET registerUserForm , dir "_register" $ methodSP POST $ withData registerUser , dir "_login" $ methodSP GET loginUserForm , dir "_login" $ methodSP POST $ withData loginUser , dir "_logout" $ methodSP GET $ withData logoutUser , dir "_resetPassword" $ methodSP GET $ withData resetPasswordRequestForm , dir "_resetPassword" $ methodSP POST $ withData resetPasswordRequest , dir "_doResetPassword" $ methodSP GET $ withData resetPassword , dir "_doResetPassword" $ methodSP POST $ withData doResetPassword , dir "_user" currentUser ] loginUserHTTP :: Params -> Handler loginUserHTTP params = do base' <- getWikiBase let destination = pDestination params `orIfNull` (base' ++ "/") seeOther (encUrl destination) $ toResponse () logoutUserHTTP :: Handler logoutUserHTTP = unauthorized $ toResponse () -- will this work? httpAuthHandlers :: [Handler] httpAuthHandlers = [ dir "_logout" $ logoutUserHTTP , dir "_login" $ withData loginUserHTTP , dir "_user" currentUser ] -- Login using RPX (see RPX development docs at https://rpxnow.com/docs) loginRPXUser :: RPars -- ^ The parameters passed by the RPX callback call (after authentication has taken place -> Handler loginRPXUser params = do cfg <- getConfig ref <- getReferer let mtoken = rToken params if isNothing mtoken then do let url = baseUrl cfg ++ "/_login?destination=" ++ (fromMaybe ref $ rDestination params) if null (rpxDomain cfg) then error "rpx-domain is not set." else do let rpx = "https://" ++ rpxDomain cfg ++ ".rpxnow.com/openid/v2/signin?token_url=" ++ urlEncode url see rpx else do -- We got an answer from RPX, this might also return an exception. uid' :: Either String R.Identifier <- liftIO $ R.authenticate (rpxKey cfg) $ fromJust mtoken uid <- case uid' of Right u -> return u Left err -> error err liftIO $ logM "gitit.loginRPXUser" DEBUG $ "uid:" ++ show uid -- We need to get an unique identifier for the user -- The 'identifier' is always present but can be rather cryptic -- The 'verifiedEmail' is also unique and is a more readable choice -- so we use it if present. let userId = R.userIdentifier uid let email = prop "verifiedEmail" uid user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none" updateGititState $ \s -> s { users = M.insert userId user (users s) } key <- newSession (SessionData userId) 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 instance FromData RPars where fromData = do 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 = [ dir "_logout" $ methodSP GET $ withData logoutUser , dir "_login" $ withData loginRPXUser , dir "_user" currentUser ] -- | Returns username of logged in user or null string if nobody logged in. currentUser :: Handler currentUser = do req <- askRq ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)