{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.ProfileData.EditProfileData where
import Clckwrks
import Clckwrks.Monad (plugins)
import Clckwrks.Admin.Template (template)
import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)
import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))
import Control.Monad.State (get)
import Control.Monad.Trans (liftIO)
import qualified Data.Acid as Acid
import Data.Text (pack)
import qualified Data.Text as Text
import Data.Text.Lazy (Text)
import Data.Maybe (fromMaybe)
import Data.UserId (UserId)
import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..))
import Language.Haskell.HSX.QQ (hsx)
import Text.Reform ((++>), mapView, transformEitherM)
import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs)
import Text.Reform.Happstack (reform)
import HSP.XMLGenerator
import HSP.XML
import Web.Plugins.Core (Plugin(..), getPluginState)
editProfileDataPage :: ProfileDataURL -> Clck ProfileDataURL Response
editProfileDataPage here =
do mUid <- getUserId
case mUid of
Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text)
(Just uid) ->
do
p <- plugins <$> get
~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)
~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid)
pd <- query (GetProfileData uid)
action <- showURL here
template "Edit Profile Data" () $ [hsx|
<%>
<% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %>
-- <div ng-controller="UsernamePasswordCtrl">
-- <up-change-password />
-- </div>
</%> |]
where
updated :: () -> Clck ProfileDataURL Response
updated () =
do seeOtherURL here
profileDataFormlet :: User -> ProfileData -> ClckForm ProfileDataURL ()
profileDataFormlet u@User{..} pd =
divHorizontal $
errorList ++>
((,) <$> (divControlGroup (label' "Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email)))))
<*> (divControlGroup (label' "DisplayName" ++> (divControls (inputText (maybe Text.empty unDisplayName (displayName pd))))))
<* (divControlGroup (divControls (inputSubmit (pack "Update") `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|<div class="form-horizontal"><% xml %></div>|]])
divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])
divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]])
updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ())
updateProfileData (eml, dn) =
do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml))
}
p <- plugins <$> get
~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)
liftIO $ Acid.update authenticateState (UpdateUser user)
pd <- query (GetProfileData _userId)
update (SetProfileData (pd { displayName = if Text.null dn then Nothing else Just (DisplayName dn) }))
pure $ Right ()