module Network.Gitit.Authentication ( loginUserForm
, formAuthHandlers
, httpAuthHandlers
, rpxAuthHandlers
, githubAuthHandlers) 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.Gitit.Authentication.Github
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 (liftIO)
import System.Exit
import System.Log.Logger (logM, Priority(..))
import Data.Char (isAlphaNum, isAlpha)
import qualified Data.Map as M
import Text.Pandoc.Shared (substitute)
import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
import Network.URL (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 ! [thefor "username"] << "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 " ++
renderHtmlFragment (stringToHtml 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
sharedForm :: Maybe User -> GititServerPart Html
sharedForm mbUser = withData $ \params -> do
cfg <- getConfig
dest <- case pDestination params of
"" -> getReferer
x -> return x
let accessQ = case mbUser of
Just _ -> noHtml
Nothing -> case accessQuestion cfg of
Nothing -> noHtml
Just (prompt, _) -> label ! [thefor "accessCode"] << 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 ! [thefor "username"] <<
"Username (at least 3 letters or digits):"
+++ br +++
textfield "username" ! [size "20", intAttr "tabindex" 2] +++ br
Just user -> label ! [thefor "username"] <<
("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 ! [thefor "email"] << "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 ! [thefor "password"]
<< ("Password (at least 6 characters," ++
" including at least one non-letter):")
, br
, X.password "password" ! [size "20", intAttr "tabindex" 4]
, stringToHtml " "
, br
, label ! [thefor "password2"] << "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 isValidUsernameChar c = isAlphaNum c || c == ' '
let isValidUsername u = length u >= 3 && all isValidUsernameChar 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 validationType of
ResetPassword -> True
Register -> 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)
then return $ Left "missing-challenge-or-response"
else liftIO $ do
mbIPaddr <- lookupIPAddr peer
let ipaddr = fromMaybe (error $ "Could not find ip address for " ++ peer)
mbIPaddr
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),
"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
loginForm :: String -> GititServerPart Html
loginForm dest = do
cfg <- getConfig
base' <- getWikiBase
return $ gui (base' ++ "/_login") ! [identifier "loginForm"] <<
fieldset <<
[ label ! [thefor "username"] << "Username "
, textfield "username" ! [size "15", intAttr "tabindex" 1]
, stringToHtml " "
, label ! [thefor "password"] << "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, " ++
renderHtmlFragment (stringToHtml uname))
else
withMessages ["Invalid username or password."] loginUserForm
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" $ method GET >> registerUserForm
, dir "_register" $ method POST >> withData registerUser
, dir "_login" $ method GET >> loginUserForm
, dir "_login" $ method POST >> withData loginUser
, dir "_logout" $ method GET >> withData logoutUser
, dir "_resetPassword" $ method GET >> withData resetPasswordRequestForm
, dir "_resetPassword" $ method POST >> withData resetPasswordRequest
, dir "_doResetPassword" $ method GET >> withData resetPassword
, dir "_doResetPassword" $ method 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 ()
httpAuthHandlers :: [Handler]
httpAuthHandlers =
[ dir "_logout" logoutUserHTTP
, dir "_login" $ withData loginUserHTTP
, dir "_user" currentUser ]
oauthGithubCallback :: GithubConfig
-> GithubCallbackPars
-> Handler
oauthGithubCallback ghConfig githubCallbackPars =
withData $ \(sk :: Maybe SessionKey) ->
do
mbSd <- maybe (return Nothing) getSession sk
mbGititState <- case mbSd of
Nothing -> return Nothing
Just sd -> return $ sessionGithubState sd
let gititState = fromMaybe (error "No Github state found in session (is it the same domain?)") mbGititState
mUser <- getGithubUser ghConfig githubCallbackPars gititState
base' <- getWikiBase
let destination = base' ++ "/"
case mUser of
Right user -> do
let userEmail = uEmail user
updateGititState $ \s -> s { users = M.insert userEmail user (users s) }
addUser (uUsername user) user
key <- newSession (sessionData userEmail)
cfg <- getConfig
addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
seeOther (encUrl destination) $ toResponse ()
Left err -> do
liftIO $ logM "gitit" WARNING $ "Login Failed: " ++ ghUserMessage err ++ maybe "" (". Github response" ++) (ghDetails err)
let url = destination ++ "?message=" ++ ghUserMessage err
seeOther (encUrl url) $ toResponse ()
githubAuthHandlers :: GithubConfig
-> [Handler]
githubAuthHandlers ghConfig =
[ dir "_logout" $ withData logoutUser
, dir "_login" $ loginGithubUser $ oAuth2 ghConfig
, dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig
, dir "_user" currentUser ]
loginRPXUser :: RPars
-> 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
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
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
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" $ method GET >> withData logoutUser
, dir "_login" $ withData loginRPXUser
, dir "_user" currentUser ]
currentUser :: Handler
currentUser = do
req <- askRq
ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)