{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.ProfileData.EditProfileDataFor where import Clckwrks import Clckwrks.Admin.Template (template) import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) import Clckwrks.Authenticate.Monad () import Data.Maybe (fromMaybe) import Data.Set as Set import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as LT import qualified Data.Text as Text import Data.UserId (UserId) import Language.Haskell.HSX.QQ (hsx) import Happstack.Authenticate.Core (Email(..), GetUserByUserId(..), User(..), UserId(..), Username(..)) import Happstack.Authenticate.Password.Core (SetPassword(..), mkHashedPass) import HSP.XMLGenerator import HSP.XML import Text.Reform ((++>), mapView, transformEitherM) import Text.Reform.Happstack (reform) import Text.Reform.HSP.Text (inputCheckboxes, inputPassword, inputText, labelText, inputSubmit, fieldset, ol, li, form, setAttrs) editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response editProfileDataForPage here uid = do pd <- query (GetProfileData uid) mu <- query (GetUserByUserId uid) case mu of Nothing -> template "Edit Profile Data" () $ [hsx|
Invalid UserId <% show uid %>
|] (Just u) -> do action <- showURL here template "Edit Profile Data" () $ [hsx|

User Info

UserId
<% show $ _unUserId $ _userId u %>
Username
<% _unUsername $ _username u %>
Email
<% maybe Text.empty _unEmail (_email u) %>

Roles

<% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>

Update User's Password

<% reform (form action) "pf" updated Nothing (passwordForFormlet uid) %>
|] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here passwordForFormlet :: UserId -> ClckForm ProfileDataURL () passwordForFormlet userid = (fieldset $ (divControlGroup $ (divControls (label' "new password" ++> inputPassword)) ) <* (divControlGroup $ divControls $ inputSubmit "Change Password" `setAttrs` [("class" := "btn") :: Attr Text Text]) ) `transformEitherM` updatePassword where label' :: Text -> ClckForm ProfileDataURL () label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) -- divHorizontal = mapView (\xml -> [[hsx|
<% xml %>
|]]) divControlGroup = mapView (\xml -> [[hsx|
<% xml %>
|]]) divControls = mapView (\xml -> [[hsx|
<% xml %>
|]]) updatePassword :: Text.Text -> Clck ProfileDataURL (Either ClckFormError ()) updatePassword newPw | Text.null newPw = pure (Right ()) | otherwise = do hp <- mkHashedPass newPw update (SetPassword userid hp) pure (Right ()) profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL () profileDataFormlet pd@ProfileData{..} = (fieldset $ (divControlGroup $ (divControls (inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text))) <* (divControlGroup $ divControls $ inputSubmit "Update Roles" `setAttrs` [("class" := "btn") :: Attr Text Text]) ) `transformEitherM` updateProfileData where label' :: Text -> ClckForm ProfileDataURL () label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) -- divHorizontal = mapView (\xml -> [[hsx|
<% xml %>
|]]) divControlGroup = mapView (\xml -> [[hsx|
<% xml %>
|]]) divControls = mapView (\xml -> [[hsx|
<% xml %>
|]]) updateProfileData :: [Role] -> Clck ProfileDataURL (Either ClckFormError ()) updateProfileData roles' = do let newPd = pd { roles = Set.fromList roles' } update (SetProfileData newPd) pure (Right ()) -- ((li $ labelText "roles:") ++> ((li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text))