{-# LANGUAGE ScopedTypeVariables #-}
-- | user handling
module Handler.User where

import Import
import Control.Monad (join, liftM)
import Web.MangoPay
import Yesod.Form.Jquery
import Yesod.MangoPay
import Yesod.MangoPay.Util

-- | get the form to edit any type of user
getUserR :: AnyUserId -> Handler Html
getUserR uid=do
  eu <- runYesodMPTToken $ getUser uid
  case eu of
    (Left nu)->do
      let muser=Just nu
      (widget, enctype) <- generateFormPost $ naturalUserForm muser
      defaultLayout $ do
            setTitleI MsgTitleNUser
            let (formMethod, msgFormTitle) = formVariables $ Left muser
            nuserWidget muser (formMethod, enctype, widget) msgFormTitle
    (Right lu)->do
      let muser=Just lu
      (widget, enctype) <- generateFormPost $ legalUserForm muser
      defaultLayout $ do
            let (formMethod, msgFormTitle) = formVariables $ Right muser
            setTitleI MsgTitleLUser
            luserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | get a natural user form
getNUserR :: Handler Html
getNUserR =do
  (muser,widget,enctype)<- userGet naturalUserForm fetchNaturalUser
  defaultLayout $ do
        let (formMethod, msgFormTitle) = formVariables $ Left muser
        setTitleI MsgTitleNUser
        nuserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | post a natural user form
postNUserR :: Handler Html
postNUserR = do
  (muser,widget,enctype)<- userPost naturalUserForm createNaturalUser
  defaultLayout $ do
        let (formMethod, msgFormTitle) = formVariables $ Left muser
        setTitleI MsgTitleNUser
        nuserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | put a natural user form, to modify an existing natural user
putNUserR :: Handler Html
putNUserR = do
  (muser,widget,enctype)<- userPost naturalUserForm modifyNaturalUser
  defaultLayout $ do
        setTitleI MsgTitleNUser
        let (formMethod, msgFormTitle) = formVariables $ Left muser
        nuserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | get a legal user form
getLUserR :: Handler Html
getLUserR = do
  (muser,widget,enctype)<- userGet legalUserForm fetchLegalUser
  defaultLayout $ do
        let (formMethod, msgFormTitle) = formVariables $ Right muser
        setTitleI MsgTitleLUser
        luserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | post a legal user form
postLUserR :: Handler Html
postLUserR = do
  (muser,widget,enctype)<- userPost legalUserForm createLegalUser
  defaultLayout $ do
        let (formMethod, msgFormTitle) = formVariables $ Right muser
        setTitleI MsgTitleLUser
        luserWidget muser (formMethod, enctype, widget) msgFormTitle


-- | post a legal user form
putLUserR :: Handler Html
putLUserR = do
  (muser,widget,enctype)<- userPost legalUserForm modifyLegalUser
  defaultLayout $ do
        let (formMethod, msgFormTitle) = formVariables $ Right muser
        setTitleI MsgTitleLUser
        luserWidget muser (formMethod, enctype, widget) msgFormTitle

-- | common code for retrieval and form building
userGet :: HtmlForm a
                 -> (Text -> AccessToken -> MangoPayT Handler a)
                 -> Handler (Maybe a, Widget, Enctype)
userGet form fetch =do
    muid<-lookupGetParam "id"
    muser<-case muid of
      Just uid->liftM Just $ runYesodMPTToken $ fetch uid
      _->return Nothing
    (widget, enctype) <- generateFormPost $ form muser
    return (muser,widget,enctype)

-- | common code for storing, retrieving update and form building
userPost :: HtmlForm a
                 -> (a -> AccessToken -> MangoPayT Handler a)
                 -> Handler (Maybe a, Widget, Enctype)
userPost form store = do
    ((result, _), _) <- runFormPost $ form Nothing
    muser<-case result of
              FormSuccess u -> do
                catchMP (do
                  user<-runYesodMPTToken $ store u
                  setMessageI MsgUserDone
                  return (Just user)
                  )
                  (\e->do
                    setMessage $ toHtml $ show e
                    return (Just u)
                  )
              _ -> do
                setMessageI MsgErrorData
                return Nothing
    (widget, enctype) <- generateFormPost $ form muser
    return (muser,widget,enctype)


-- | form for natural user
naturalUserForm ::  HtmlForm NaturalUser
naturalUserForm muser= renderDivs $ NaturalUser
    <$> aopt hiddenField "" (uId <$> muser)
    <*> pure (join $ uCreationDate <$> muser)
    <*> areq textField (localizedFS MsgUserEmail) (uEmail <$> muser)
    <*> areq textField (localizedFS MsgUserFirst) (uFirstName <$> muser)
    <*> areq textField (localizedFS MsgUserLast) (uLastName <$> muser)
    <*> aopt textField (localizedFS MsgUserAddress) (uAddress <$> muser)
    <*> (dayToMpTime <$> areq (jqueryDayField def
        { jdsChangeYear = True -- give a year dropdown
        , jdsYearRange = "1900:-5" -- 1900 till five years ago
        }) (localizedFS MsgUserBirthday) (mpTimeToDay <$> uBirthday <$> muser))
    <*> areq countryField (localizedFS MsgUserNationality)  (uNationality <$> muser)
    <*> areq countryField (localizedFS MsgUserCountry) (uCountryOfResidence <$> muser)
    <*> aopt textField (localizedFS MsgUserOccupation) (uOccupation <$> muser)
    <*> aopt (selectFieldList ranges) (localizedFS MsgUserIncome) (uIncomeRange <$> muser)
    <*> aopt textField (localizedFS MsgUserCustomData) (uTag <$> muser)
    <*> aopt textField (disabled $ localizedFS MsgUserProofIdentity) (uProofOfIdentity <$> muser) -- value comes from Documents uploaded
    <*> aopt textField (disabled $ localizedFS MsgUserProofAddress) (uProofOfAddress <$> muser) -- value comes from Documents uploaded
  where

-- | form for legal user
legalUserForm :: HtmlForm LegalUser
legalUserForm muser= renderDivs $ LegalUser
    <$> aopt hiddenField "" (lId <$> muser)
    <*> pure (join $ lCreationDate <$> muser)
    <*> areq textField (localizedFS MsgUserEmail) (lEmail <$> muser)
    <*> areq textField (localizedFS MsgUserName) (lName <$> muser)
    <*> areq (selectFieldList ranges) (localizedFS MsgUserPersonType) (lLegalPersonType <$> muser)
    <*> aopt textField (localizedFS MsgUserHQAddress) (lHeadquartersAddress <$> muser)
    <*> areq textField (localizedFS MsgUserRepFirst) (lLegalRepresentativeFirstName <$> muser)
    <*> areq textField (localizedFS MsgUserRepLast) (lLegalRepresentativeLastName <$> muser)
    <*> aopt textField (localizedFS MsgUserRepAddress) (lLegalRepresentativeAddress <$> muser)
    <*> aopt textField (localizedFS MsgUserRepEmail) (lLegalRepresentativeEmail <$> muser)
    <*> (dayToMpTime <$> areq (jqueryDayField def
        { jdsChangeYear = True -- give a year dropdown
        , jdsYearRange = "1900:-5" -- 1900 till five years ago
        }) (localizedFS MsgUserRepBirthday) (mpTimeToDay <$> lLegalRepresentativeBirthday <$> muser))
    <*> areq countryField (localizedFS MsgUserRepNationality) (lLegalRepresentativeNationality <$> muser)
    <*> areq countryField (localizedFS MsgUserRepCountry) (lLegalRepresentativeCountryOfResidence <$> muser)
    <*> pure Nothing  -- value comes from Documents uploaded (I think)
    <*> aopt textField (localizedFS MsgUserCustomData) (lTag <$> muser)
    <*> pure Nothing  -- value comes from Documents uploaded
    <*> pure Nothing -- value comes from Documents uploaded


formVariables :: Either (Maybe NaturalUser) (Maybe LegalUser) -> (Text, AppMessage)
formVariables = either (\n -> process $ mid uId n) (\l -> process $ mid lId l)
  where mid getId mu = do
              u  <- mu
              getId u
        process = maybe ("", MsgUserCreate) (\i -> ("?_method=PUT", MsgUserModify $ i))


----------------------------------------------------------------------


nuserWidget
  :: Maybe NaturalUser
  -> (Text, Enctype, Widget)
  -> AppMessage
  -> Widget
nuserWidget muser (formMethod, enctype, widget) msgFormTitle = $(widgetFile "nuser")
{-# NOINLINE nuserWidget #-}


luserWidget
  :: Maybe LegalUser
  -> (Text, Enctype, Widget)
  -> AppMessage
  -> Widget
luserWidget muser (formMethod, enctype, widget) msgFormTitle = $(widgetFile "luser")
{-# NOINLINE luserWidget #-}
