hackage-server-0.4: Distribution/Server/Features/UserSignup.hs
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving,
TypeFamilies, TemplateHaskell,
RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-}
module Distribution.Server.Features.UserSignup (
initUserSignupFeature,
UserSignupFeature(..),
) where
import Distribution.Server.Framework
import Distribution.Server.Framework.Templating
import Distribution.Server.Framework.BackupDump
import Distribution.Server.Framework.BackupRestore
import Distribution.Server.Features.Users
import Distribution.Server.Features.UserDetails
import Distribution.Server.Users.Types
import qualified Distribution.Server.Users.Users as Users
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data
import qualified Data.ByteString.Base16 as Base16
import Data.Char (isSpace, isPrint, isAlphaNum)
import Data.Typeable (Typeable)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.SafeCopy (base, deriveSafeCopy)
import Distribution.Text (display)
import Data.Time (UTCTime, getCurrentTime)
import Text.CSV (CSV, Record)
import System.IO
import Network.Mail.Mime
import Network.URI (URI(..), URIAuth(..))
-- | A feature to allow open account signup, and password reset,
-- both with email confirmation.
--
data UserSignupFeature = UserSignupFeature {
userSignupFeatureInterface :: HackageFeature
}
instance IsHackageFeature UserSignupFeature where
getFeatureInterface = userSignupFeatureInterface
-----------------
-- Signup flow:
--
-- GET account request page
-- POST account request, including username and email
-- suitable fail if username taken
-- does not yet create or reserve the account
-- makes entry in signup table, with random nonce
-- send email to user with link to account confirm
-- GET account confirm page (with nonce in url)
-- POST account confirm (with nonce in url)
-- finally create account.
--
--
-- Reset flow:
--
-- GET password reset request page
-- POST username and email
-- makes entry in reset table, with random nonce
-- send email to user with link to reset
-- GET password change page (with nonce in url)
-- POST password change (with nonce in url)
-- set new password
--
-------------------------
-- Types of stored data
--
data SignupResetInfo = SignupInfo {
signupUserName :: !Text,
signupRealName :: !Text,
signupContactEmail :: !Text,
nonceTimestamp :: !UTCTime
}
| ResetInfo {
resetUserId :: !UserId,
nonceTimestamp :: !UTCTime
}
deriving (Eq, Show, Typeable)
newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo)
deriving (Eq, Show, Typeable, MemSize)
newtype Nonce = Nonce ByteString
deriving (Eq, Ord, Show, Typeable, MemSize)
emptySignupResetTable :: SignupResetTable
emptySignupResetTable = SignupResetTable Map.empty
instance MemSize SignupResetInfo where
memSize (SignupInfo a b c d) = memSize4 a b c d
memSize (ResetInfo a b) = memSize2 a b
$(deriveSafeCopy 0 'base ''SignupResetInfo)
$(deriveSafeCopy 0 'base ''SignupResetTable)
$(deriveSafeCopy 0 'base ''Nonce)
------------------------------
-- Nonces
--
newRandomNonce :: IO Nonce
newRandomNonce = do
raw <- withFile "/dev/urandom" ReadMode $ \h ->
BS.hGet h 10
return $! Nonce (Base16.encode raw)
renderNonce :: Nonce -> String
renderNonce (Nonce nonce) = BS.unpack nonce
------------------------------
-- State queries and updates
--
getSignupResetTable :: Query SignupResetTable SignupResetTable
getSignupResetTable = ask
replaceSignupResetTable :: SignupResetTable -> Update SignupResetTable ()
replaceSignupResetTable = put
lookupSignupResetInfo :: Nonce -> Query SignupResetTable (Maybe SignupResetInfo)
lookupSignupResetInfo nonce = do
SignupResetTable tbl <- ask
return $! Map.lookup nonce tbl
addSignupResetInfo :: Nonce -> SignupResetInfo -> Update SignupResetTable Bool
addSignupResetInfo nonce info = do
SignupResetTable tbl <- get
if not (Map.member nonce tbl)
then do put $! SignupResetTable (Map.insert nonce info tbl)
return True
else return False
deleteSignupResetInfo :: Nonce -> Update SignupResetTable ()
deleteSignupResetInfo nonce = do
SignupResetTable tbl <- get
put $! SignupResetTable (Map.delete nonce tbl)
makeAcidic ''SignupResetTable [
--queries
'getSignupResetTable,
'lookupSignupResetInfo,
--updates
'replaceSignupResetTable,
'addSignupResetInfo,
'deleteSignupResetInfo
]
---------------------
-- State components
--
signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable)
signupResetStateComponent stateDir = do
st <- openLocalStateFrom (stateDir </> "db" </> "UserSignupReset") emptySignupResetTable
return StateComponent {
stateDesc = "State to keep track of outstanding requests for user signup and password resets"
, stateHandle = st
, getState = query st GetSignupResetTable
, putState = update st . ReplaceSignupResetTable
, backupState = \tbl -> [csvToBackup ["signups.csv"] (signupInfoToCSV tbl)
,csvToBackup ["resets.csv"] (resetInfoToCSV tbl)]
, restoreState = signupResetBackup
, resetState = signupResetStateComponent
}
----------------------------
-- Data backup and restore
--
signupResetBackup :: RestoreBackup SignupResetTable
signupResetBackup = go []
where
go :: [(Nonce, SignupResetInfo)] -> RestoreBackup SignupResetTable
go st =
RestoreBackup {
restoreEntry = \entry -> case entry of
BackupByteString ["signups.csv"] bs -> do
csv <- importCSV "signups.csv" bs
signups <- importSignupInfo csv
return (go (signups ++ st))
BackupByteString ["resets.csv"] bs -> do
csv <- importCSV "resets.csv" bs
resets <- importResetInfo csv
return (go (resets ++ st))
_ -> return (go st)
, restoreFinalize =
return (SignupResetTable (Map.fromList st))
}
importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)]
importSignupInfo = sequence . map fromRecord . drop 2
where
fromRecord :: Record -> Restore (Nonce, SignupResetInfo)
fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do
timestamp <- parseUTCTime "timestamp" timestampStr
let nonce = Nonce (BS.pack nonceStr)
signupinfo = SignupInfo {
signupUserName = T.pack usernameStr,
signupRealName = T.pack realnameStr,
signupContactEmail = T.pack emailStr,
nonceTimestamp = timestamp
}
return (nonce, signupinfo)
fromRecord x = fail $ "Error processing signup info record: " ++ show x
signupInfoToCSV :: SignupResetTable -> CSV
signupInfoToCSV (SignupResetTable tbl)
= ["0.1"]
: [ "token", "username", "realname", "email", "timestamp" ]
: [ [ renderNonce nonce
, T.unpack signupUserName
, T.unpack signupRealName
, T.unpack signupContactEmail
, formatUTCTime nonceTimestamp
]
| (nonce, SignupInfo{..}) <- Map.toList tbl ]
importResetInfo :: CSV -> Restore [(Nonce, SignupResetInfo)]
importResetInfo = sequence . map fromRecord . drop 2
where
fromRecord :: Record -> Restore (Nonce, SignupResetInfo)
fromRecord [nonceStr, useridStr, timestampStr] = do
userid <- parseText "userid" useridStr
timestamp <- parseUTCTime "timestamp" timestampStr
let nonce = Nonce (BS.pack nonceStr)
signupinfo = ResetInfo {
resetUserId = userid,
nonceTimestamp = timestamp
}
return (nonce, signupinfo)
fromRecord x = fail $ "Error processing signup info record: " ++ show x
resetInfoToCSV :: SignupResetTable -> CSV
resetInfoToCSV (SignupResetTable tbl)
= ["0.1"]
: [ "token", "userid", "timestamp" ]
: [ [ renderNonce nonce
, display resetUserId
, formatUTCTime nonceTimestamp
]
| (nonce, ResetInfo{..}) <- Map.toList tbl ]
----------------------------------------
-- Feature definition & initialisation
--
initUserSignupFeature :: ServerEnv
-> UserFeature
-> UserDetailsFeature
-> IO UserSignupFeature
initUserSignupFeature env@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode}
users userdetails = do
-- Canonical state
signupResetState <- signupResetStateComponent serverStateDir
-- Page templates
templates <- loadTemplates serverTemplatesMode
[serverTemplatesDir, serverTemplatesDir </> "UserSignupReset"]
[ "SignupRequest", "SignupConfirmationEmail"
, "SignupEmailSent", "SignupConfirm"
, "ResetRequest", "ResetConfirmationEmail"
, "ResetEmailSent", "ResetConfirm" ]
let feature = userSignupFeature env users userdetails
signupResetState templates
return feature
userSignupFeature :: ServerEnv
-> UserFeature
-> UserDetailsFeature
-> StateComponent AcidState SignupResetTable
-> Templates
-> UserSignupFeature
userSignupFeature ServerEnv{serverBaseURI} UserFeature{..} UserDetailsFeature{..}
signupResetState templates
= UserSignupFeature {..}
where
userSignupFeatureInterface = (emptyHackageFeature "user-signup-reset") {
featureDesc = "Extra information about user accounts, email addresses etc."
, featureResources = [signupRequestsResource,
signupRequestResource,
resetRequestsResource,
resetRequestResource]
, featureState = [abstractAcidStateComponent signupResetState]
, featureCaches = []
}
-- Resources
--
signupRequestsResource =
(resourceAt "/users/register-request") {
resourceDesc = [ (GET, "Page to let you make a request for an account")
, (POST, "Create a new account signup request") ]
, resourceGet = [ ("", handlerGetSignupRequestNew) ]
, resourcePost = [ ("", handlerPostSignupRequestNew) ]
}
signupRequestResource =
(resourceAt "/users/register-request/:nonce") {
resourceDesc = [ (GET, "Page for confirming outstanding signup request")
, (POST, "Confirm signup request and create the new account") ]
, resourceGet = [ ("", handlerGetSignupRequestOutstanding) ]
, resourcePost = [ ("", handlerPostSignupRequestOutstanding) ]
}
resetRequestsResource =
(resourceAt "/users/password-reset") {
resourceDesc = [ (GET, "Page to let you make a request for a password reset")
, (POST, "Create a new password reset request") ]
, resourceGet = [ ("", handlerGetResetRequestNew) ]
, resourcePost = [ ("", handlerPostResetRequestNew) ]
}
resetRequestResource =
(resourceAt "/users/password-reset/:nonce") {
resourceDesc = [ (GET, "Page for confirming password reset request and entering new password")
, (POST, "Confirm password reset and set new password") ]
, resourceGet = [ ("", handlerGetResetRequestOutstanding) ]
, resourcePost = [ ("", handlerPostResetRequestOutstanding) ]
}
-- Queries and updates
--
querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)
querySignupInfo nonce =
queryState signupResetState (LookupSignupResetInfo nonce)
>>= return . justSignupInfo
where
justSignupInfo (Just info@SignupInfo{}) = Just info
justSignupInfo _ = Nothing
queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)
queryResetInfo nonce =
queryState signupResetState (LookupSignupResetInfo nonce)
>>= return . justResetInfo
where
justResetInfo (Just info@ResetInfo{}) = Just info
justResetInfo _ = Nothing
updateAddSignupResetInfo :: Nonce -> SignupResetInfo -> MonadIO m => m Bool
updateAddSignupResetInfo nonce signupInfo =
updateState signupResetState (AddSignupResetInfo nonce signupInfo)
updateDeleteSignupResetInfo :: Nonce -> MonadIO m => m ()
updateDeleteSignupResetInfo nonce =
updateState signupResetState (DeleteSignupResetInfo nonce)
-- Request handlers
--
nonceInPath :: MonadPlus m => DynamicPath -> m Nonce
nonceInPath dpath = maybe mzero return (Nonce . BS.pack <$> lookup "nonce" dpath)
lookupSignupInfo :: Nonce -> ServerPartE SignupResetInfo
lookupSignupInfo nonce = querySignupInfo nonce
>>= maybe (errNoNonce "account signup") return
lookupResetInfo :: Nonce -> ServerPartE SignupResetInfo
lookupResetInfo nonce = queryResetInfo nonce
>>= maybe (errNoNonce "password reset") return
errNoNonce thing = errNotFound "Not found"
[MText $ "The " ++ thing ++ " token does not exist. It could be that it "
++ "has been used already, or that it has expired."]
handlerGetSignupRequestNew :: DynamicPath -> ServerPartE Response
handlerGetSignupRequestNew _ = do
template <- getTemplate templates "SignupRequest"
ok $ toResponse $ template []
handlerPostSignupRequestNew :: DynamicPath -> ServerPartE Response
handlerPostSignupRequestNew _ = do
templateEmail <- getTemplate templates "SignupConfirmationEmail"
templateConfirmation <- getTemplate templates "SignupEmailSent"
(username, realname, useremail) <- lookUserNameEmail
nonce <- liftIO newRandomNonce
timestamp <- liftIO getCurrentTime
let signupInfo = SignupInfo {
signupUserName = username,
signupRealName = realname,
signupContactEmail = useremail,
nonceTimestamp = timestamp
}
let mailFrom = Address (Just (T.pack "Hackage website"))
(T.pack ("noreply@" ++ uriRegName ourHost))
mail = (emptyMail mailFrom) {
mailTo = [Address (Just realname) useremail],
mailHeaders = [(BS.pack "Subject",
T.pack "Hackage account confirmation")],
mailParts = [[Part (T.pack "text/plain; charset=utf-8")
None Nothing [] mailBody]]
}
mailBody = renderTemplate $ templateEmail
[ "realname" $= realname
, "confirmlink" $= show serverBaseURI {
uriPath = "/users/register-request/"
++ renderNonce nonce
}
, "serverhost" $= show serverBaseURI
]
Just ourHost = uriAuthority serverBaseURI
updateAddSignupResetInfo nonce signupInfo
liftIO $ renderSendMail mail --TODO: if we need any configuration of
-- sendmail stuff, has to go here
resp 202 $ toResponse $
templateConfirmation
[ "useremail" $= useremail ]
where
lookUserNameEmail = do
(username, realname, useremail) <-
msum [ body $ (,,) <$> lookText' "username"
<*> lookText' "realname"
<*> lookText' "email"
, errBadRequest "Missing form fields" [] ]
guardValidLookingUserName username
guardValidLookingName realname
guardValidLookingEmail useremail
return (username, realname, useremail)
guardValidLookingName str = either errBadUserName return $ do
guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
guard (T.all isPrint str) ?! "Unexpected character in name, please use only printable Unicode characters."
guardValidLookingUserName str = either errBadRealName return $ do
guard (T.length str <= 50) ?! "Sorry, we didn't expect login names to be longer than 50 characters."
guard (T.all isAsciiChar str) ?! "Sorry, login names have to be ASCII characters only, no spaces or symbols."
where
isAsciiChar c = c < '\127' && isAlphaNum c
guardValidLookingEmail str = either errBadEmail return $ do
guard (T.length str <= 100) ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
guard (T.all isPrint str) ?! "Unexpected character in email address, please use only printable Unicode characters."
guard hasAtSomewhere ?! "Oops, that doesn't look like an email address."
guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <person@example.com> style."
where
isAngle c = c == '<' || c == '>'
hasAtSomewhere =
let (before, after) = T.span (/= '@') str
in T.length before >= 1
&& T.length after > 1
errBadUserName err = errBadRequest "Problem with login name" [MText err]
errBadRealName err = errBadRequest "Problem with name"[MText err]
errBadEmail err = errBadRequest "Problem with email address" [MText err]
handlerGetSignupRequestOutstanding :: DynamicPath -> ServerPartE Response
handlerGetSignupRequestOutstanding dpath = do
nonce <- nonceInPath dpath
SignupInfo {..} <- lookupSignupInfo nonce
template <- getTemplate templates "SignupConfirm"
resp 202 $ toResponse $
template
[ "realname" $= signupRealName
, "username" $= signupUserName
, "useremail" $= signupContactEmail
, "posturl" $= renderResource signupRequestResource
[renderNonce nonce]
]
handlerPostSignupRequestOutstanding :: DynamicPath -> ServerPartE Response
handlerPostSignupRequestOutstanding dpath = do
nonce <- nonceInPath dpath
SignupInfo {..} <- lookupSignupInfo nonce
(passwd, passwdRepeat) <- lookPasswd
when (passwd /= passwdRepeat) errPasswdMismatch
updateDeleteSignupResetInfo nonce
timenow <- liftIO getCurrentTime
let username = UserName (T.unpack signupUserName)
userauth = newUserAuth username (PasswdPlain passwd)
acctDetails = AccountDetails {
accountName = signupRealName,
accountContactEmail = signupContactEmail,
accountKind = Just AccountKindRealUser,
accountAdminNotes = T.pack $ "Account created by "
++ "self-registration at "
++ show timenow
}
uid <- updateAddUser username userauth
>>= either errNameClash return
updateUserDetails uid acctDetails
seeOther (userPageUri userResource "" username) (toResponse ())
where
lookPasswd = body $ (,) <$> look "password"
<*> look "repeat-password"
errPasswdMismatch =
errBadRequest "Password mismatch"
[MText $ "The two copies of the password did not match. "
++ "Check and try again."]
errNameClash Users.ErrUserNameClash =
errBadRequest "Account login name already taken"
[MText $ "Sorry! In the time between requesting the account and "
++ "now, the login username was registered by someone else. "
++ "You can make a new account request at "
,MLink "/users/signup-request" "/users/signup-request"]
-- Password reset handlers
handlerGetResetRequestNew :: DynamicPath -> ServerPartE Response
handlerGetResetRequestNew _ = do
template <- getTemplate templates "ResetRequest"
ok $ toResponse $ template []
handlerPostResetRequestNew :: DynamicPath -> ServerPartE Response
handlerPostResetRequestNew _ = do
templateEmail <- getTemplate templates "ResetConfirmationEmail"
templateConfirmation <- getTemplate templates "ResetEmailSent"
(supplied_username, supplied_useremail) <- lookUserNameEmail
(uid, uinfo) <- lookupUserNameFull supplied_username
mudetails <- queryUserDetails uid
guardEmailMatches mudetails supplied_useremail
AccountDetails{..} <- guardSuitableAccountType uinfo mudetails
nonce <- liftIO newRandomNonce
timestamp <- liftIO getCurrentTime
let resetInfo = ResetInfo {
resetUserId = uid,
nonceTimestamp = timestamp
}
let mailFrom = Address (Just (T.pack "Hackage website"))
(T.pack ("noreply@" ++ uriRegName ourHost))
mail = (emptyMail mailFrom) {
mailTo = [Address (Just accountName) accountContactEmail],
mailHeaders = [(BS.pack "Subject",
T.pack "Hackage password reset confirmation")],
mailParts = [[Part (T.pack "text/plain; charset=utf-8")
None Nothing [] mailBody]]
}
mailBody = renderTemplate $ templateEmail
[ "realname" $= accountName
, "confirmlink" $= show serverBaseURI {
uriPath = "/users/password-reset/"
++ renderNonce nonce
}
, "serverhost" $= show serverBaseURI
]
Just ourHost = uriAuthority serverBaseURI
updateAddSignupResetInfo nonce resetInfo
liftIO $ renderSendMail mail --TODO: if we need any configuration of
-- sendmail stuff, has to go here
resp 202 $ toResponse $
templateConfirmation
[ "useremail" $= accountContactEmail ]
where
lookUserNameEmail :: ServerPartE (UserName, Text)
lookUserNameEmail =
msum [ body $ (,) <$> (UserName <$> look "username")
<*> lookText' "email"
, errBadRequest "Missing form fields" [] ]
guardEmailMatches (Just AccountDetails {accountContactEmail}) useremail
| accountContactEmail == useremail = return ()
guardEmailMatches _ _ =
errForbidden "Wrong account details"
[MText "Sorry, that does not match any account details we have on file."]
guardSuitableAccountType (UserInfo { userStatus = AccountEnabled{} })
(Just udetails@AccountDetails {
accountKind = Just AccountKindRealUser
}) = return udetails
guardSuitableAccountType _ _ =
errForbidden "Cannot reset password for this account"
[MText $ "Sorry, the self-service password reset system cannot be "
++ "used for this account at this time."]
handlerGetResetRequestOutstanding :: DynamicPath -> ServerPartE Response
handlerGetResetRequestOutstanding dpath = do
nonce <- nonceInPath dpath
ResetInfo{resetUserId} <- lookupResetInfo nonce
uinfo@UserInfo{userName} <- lookupUserInfo resetUserId
mudetails <- queryUserDetails resetUserId
AccountDetails{..} <- guardSuitableAccountType uinfo mudetails
template <- getTemplate templates "ResetConfirm"
resp 202 $ toResponse $
template
[ "realname" $= accountName
, "username" $= display userName
, "useremail" $= accountContactEmail
, "posturl" $= renderResource resetRequestResource
[renderNonce nonce]
]
handlerPostResetRequestOutstanding :: DynamicPath -> ServerPartE Response
handlerPostResetRequestOutstanding dpath = do
nonce <- nonceInPath dpath
ResetInfo{resetUserId} <- lookupResetInfo nonce
uinfo@UserInfo{userName} <- lookupUserInfo resetUserId
mudetails <- queryUserDetails resetUserId
AccountDetails{..} <- guardSuitableAccountType uinfo mudetails
(passwd, passwdRepeat) <- lookPasswd
when (passwd /= passwdRepeat) errPasswdMismatch
let userauth = newUserAuth userName (PasswdPlain passwd)
updateDeleteSignupResetInfo nonce
updateSetUserAuth resetUserId userauth >>= maybe (return ()) errDeleted
--TODO: confirmation page?
seeOther (userPageUri userResource "" userName) (toResponse ())
where
lookPasswd = body $ (,) <$> look "password"
<*> look "repeat-password"
errPasswdMismatch =
errBadRequest "Password mismatch"
[MText $ "The two copies of the password did not match. "
++ "Check and try again."]
errDeleted (Right Users.ErrDeletedUser) =
errForbidden "Account deleted"
[MText "Cannot set a new password as the user account has just been deleted."]
errDeleted (Left Users.ErrNoSuchUserId) =
errInternalError [MText "No such user id!"]