gonito/Handler/YourAccount.hs

150 lines
6.0 KiB
Haskell
Raw Normal View History

2015-09-30 20:15:33 +02:00
module Handler.YourAccount where
import Import
2016-12-03 13:36:32 +01:00
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
2015-09-30 20:15:33 +02:00
import Text.Regex.TDFA
2016-05-03 10:21:40 +02:00
import Data.Conduit.Binary
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
2016-12-03 14:14:39 +01:00
import Crypto.PasswordStore
import Yesod.Auth.HashDB (defaultStrength)
2016-05-03 10:21:40 +02:00
2015-09-30 20:15:33 +02:00
getYourAccountR :: Handler Html
getYourAccountR = do
userId <- requireAuthId
user <- runDB $ get404 userId
2015-11-11 22:37:25 +01:00
keyS <- runDB $ selectFirst [PublicKeyUser ==. userId] []
let key = publicKeyPubkey <$> entityVal <$> keyS
(formWidget, formEnctype) <- generateFormPost (yourAccountForm (userName user) (userLocalId user) key)
2015-09-30 20:15:33 +02:00
defaultLayout $ do
setTitle "Your account"
$(widgetFile "your-account")
postYourAccountR :: Handler Html
postYourAccountR = do
((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing Nothing Nothing)
userId <- requireAuthId
2016-12-03 15:19:11 +01:00
user <- runDB $ get404 userId
2016-12-03 13:36:32 +01:00
let accountData = case result of
2015-09-30 20:15:33 +02:00
FormSuccess res -> Just res
_ -> Nothing
case accountData of
Just (name, localId, mPassword, sshPubKey, avatarFile) -> do
updateUserAccount userId name localId mPassword sshPubKey avatarFile
Nothing -> do
setMessage $ toHtml ("Something went wrong, probably the password did not match" :: Text)
2015-09-30 20:15:33 +02:00
defaultLayout $ do
setTitle "Your account"
$(widgetFile "your-account")
2015-09-30 20:15:33 +02:00
2016-12-03 14:14:39 +01:00
yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo)
yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,,,)
2016-02-15 20:36:01 +01:00
<$> aopt textField (bfs MsgAccountName) (Just maybeName)
<*> aopt textField (bfs MsgId) (Just maybeLocalId)
2016-12-03 14:14:39 +01:00
<*> aopt passwordConfirmField (bfs MsgPassword) Nothing
2016-02-15 20:36:01 +01:00
<*> aopt textField (bfs MsgSshPubKey) (Just maybeSshPubKey)
2016-05-03 10:21:40 +02:00
<*> fileAFormOpt (bfs MsgAvatar)
2016-12-03 13:36:32 +01:00
localIdRegexp :: Regex
localIdRegexp = makeRegexOpts defaultCompOpt{newSyntax=True} defaultExecOpt ("\\`[a-z][-a-z0-9]{0,31}\\'" ::String)
unwantedLocalIds :: [Text]
unwantedLocalIds = ["git",
"gitolite",
"admin",
"root",
"filipg"]
isLocalIdAcceptable :: Text -> Bool
isLocalIdAcceptable localId =
match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds)
2016-12-03 14:14:39 +01:00
updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Handler ()
updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAvatarFile = do
updateJustName userId name
2016-05-03 10:21:40 +02:00
updateAvatar userId maybeAvatarFile
updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey
2016-12-03 14:14:39 +01:00
updatePassword userId maybePassword
2016-12-03 14:14:39 +01:00
updatePassword :: Key User -> Maybe Text -> Handler ()
updatePassword _ Nothing = return ()
updatePassword userId (Just password) = do
encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength
runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)]
2016-12-03 15:19:11 +01:00
setMessage $ toHtml ("Password set!" :: Text)
2016-05-03 10:21:40 +02:00
updateAvatar :: Key User -> Maybe FileInfo -> Handler ()
updateAvatar _ Nothing = return ()
updateAvatar userId (Just avatarFile) = do
fileBytes <- runResourceT $ fileSource avatarFile $$ sinkLbs
runDB $ update userId [UserAvatar =. Just (S.pack . L.unpack $ fileBytes)]
updateLocalIdAndPubKey :: Key User -> Maybe Text -> Maybe Text -> Handler ()
updateLocalIdAndPubKey userId (Just localId) maybeSshPubKey = do
if isLocalIdAcceptable localId
then
do
otherTheSame <- runDB $ selectFirst [UserLocalId ==. (Just localId), UserId !=. userId] []
case otherTheSame of
Just _ -> do
setMessage $ toHtml ("ID already used" :: Text)
Nothing -> do
user <- runDB $ get404 userId
case userLocalId user of
Just prevLocalId -> do
unless (prevLocalId == localId) $ setMessage $ toHtml ("only the administrator can change your ID" :: Text)
2016-03-14 21:12:54 +01:00
Nothing -> do
runDB $ update userId [UserLocalId =. Just localId]
setMessage $ toHtml ("ID set" :: Text)
2015-11-11 22:37:25 +01:00
runDB $ deleteWhere [PublicKeyUser ==. userId]
case maybeSshPubKey of
Just key -> do
2016-12-03 13:36:32 +01:00
_ <- runDB $ insert $ PublicKey {
2015-11-11 22:37:25 +01:00
publicKeyUser=userId,
publicKeyPubkey=key }
2016-03-14 21:12:54 +01:00
setMessage $ toHtml ("SSH public key added; now it may take 10 minutes for the keys to be active, please be patient" :: Text)
2015-11-11 22:37:25 +01:00
return ()
Nothing -> return ()
else
setMessage $ toHtml ("unexpected ID (use only lower-case letters, digits and hyphens, start with a letter)" :: Text)
updateLocalIdAndPubKey _ Nothing (Just _) = do
setMessage $ toHtml ("SSH public key cannot be added without an ID" :: Text)
updateLocalIdAndPubKey _ Nothing Nothing = return ()
updateJustName :: Key User -> Maybe Text -> Handler ()
updateJustName userId name = runDB $ update userId [UserName =. name]
2016-05-03 10:21:40 +02:00
getAvatarR :: UserId -> Handler TypedContent
getAvatarR userId = do
user <- runDB $ get404 userId
case userAvatar user of
Just avatarBytes -> do
addHeader "Content-Disposition" "attachment; filename=\"avatar.png\""
sendResponse (typePng, toContent avatarBytes)
Nothing -> do
sendFile typeSvg "static/images/male-avatar.svg"
2016-12-03 14:14:39 +01:00
passwordConfirmField :: Field Handler Text
passwordConfirmField = Field
{ fieldParse = \rawVals _fileVals ->
case rawVals of
[a, b]
| a == b -> return $ Right $ Just a
| otherwise -> return $ Left "Passwords don't match"
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs _ _ ->
2016-12-03 14:14:39 +01:00
[whamlet|
<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
2016-12-03 15:19:11 +01:00
<div>confirm new password:
2016-12-03 14:14:39 +01:00
<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
|]
, fieldEnctype = UrlEncoded
}