happs-tutorial-0.4.1: src/ControllerPostActions.hs

module ControllerPostActions where

import Control.Monad
import Control.Monad.Trans

import HAppS.Server

import StateStuff
import ViewStuff

import Misc
import ControllerMisc
import ControllerGetActions

data UserAuthInfo = UserAuthInfo String String
instance FromData UserAuthInfo where
    fromData = liftM2 UserAuthInfo (look "username")
                                   (look "password" `mplus` return "nopassword")
loginPage rglobs  =
  withData $ \(UserAuthInfo user pass) -> 
    [ ServerPartT $ \rq -> do
      mbUser <- authUser user pass

      case mbUser of 
        Nothing -> ( return . tutlayoutU rglobs [("errormsg","login error: invalid username or password")] ) "home"
        Just u ->  startsess rglobs u
        
    ]

data ChangeUserInfo = ChangeUserInfo String String String 
instance FromData ChangeUserInfo where
    fromData = liftM3 ChangeUserInfo ( (look "oldpass") `mplus` (return "no old password") )
                                     (look "password" `mplus` return "no password")
                                     (look "password2" `mplus` return "no password2")

changePasswordSP rglobs = withData $ \(ChangeUserInfo oldpass newpass1 newpass2) -> [ ServerPartT $ \rq -> do
    if newpass1 == newpass2 
       then do mbL <- liftIO $ getmbLoggedInUser rq
               maybe
                 (errW "Not logged in" rq)
                 (\u -> do mbU <- query (GetUser u)
                           case mbU of
                             Nothing -> errW ("bad username: " ++ u) rq 
                             Just user -> do update $ ChangePassword user oldpass newpass1
                                             return $ tutlayoutU rglobs [] "accountsettings-changed" )
                 mbL
       else errW "new passwords did not match" rq
  ]
  where errW msg rq = ( return . tutlayoutU rglobs [("errormsgAccountSettings", msg)] ) "changepassword" 


instance FromData ConsultantProfile where
    fromData = liftM3 ConsultantProfile ( (look "contact") `mplus` (return "") )
                                                (look "consultantblurb")
                                                --very, VERY hackish way of reading a checkbox
                                                ( return . not . (=="noval")
                                                    =<< look "listasconsultant" `mplus` return "noval" )
 
                                                

-- should reuse auth code from change password
processformEditConsultantProfile rglobs =
  withData $ \fd@(ConsultantProfile pContact pBlurb listAsC) -> [ ServerPartT $ \rq -> do
 case (mbUser rglobs) of
   Nothing -> errW "Not logged in" rq
   Just olduser@(User uname p cp js) -> do
     let newuser = User uname p (ConsultantProfile pContact pBlurb listAsC) js
     updateUserSp rglobs newuser viewEditConsultantProfile rq
  ]
  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"


data EditJob = EditJob {oldjobname::String,jobtitle::String,jobbudget::String,jobdescription::String}

-- Recommendation: ALWAYS give a default value via mplus, otherwise debugging can be hell.
instance FromData EditJob where
    fromData = liftM4 EditJob (look "oldjobname" `mplus` return "bad old job name")
                          (look "jobtitle" `mplus` return "bad job title")
                          (look "jobbudget" `mplus` return "bad budget")
                          (look "jobdescription" `mplus` return "bad job description")


  
processformEditJob :: RenderGlobals -> ServerPartT IO Response
processformEditJob rglobs@(RenderGlobals ts mbU) =
  withData $ \(EditJob ojn jn jbud jblu) -> [ ServerPartT $ \rq -> do
 case mbU of
   Nothing -> errW "Not logged in" rq
   Just olduser@(User uname p cp js) -> do
     let -- update the jobs list with the new info
         -- it feels kludgy to use map, because it would seem that you could have jobs with duplicate names
         -- probably the jobs collection could be a set, maybe fix later. it's just a demo.
         newjob = Job jn jbud jblu
         newjobs = map f js
           where f j | jobname j == ojn = newjob
                     | otherwise = j
         newuser = User uname p cp newjobs
     updateUserSp rglobs newuser (viewEditJob uname jn) rq

  ]
  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"


instance FromData Job where
    fromData = liftM3 Job (look "jobtitle" `mplus` return "bad job title")
                          (look "jobbudget" `mplus` return "bad budget")
                          (look "jobdescription" `mplus` return "bad job description")

processformNewJob rglobs@(RenderGlobals ts mbU) =
  withData $ \newjob@(Job n budget blurb) -> [ ServerPartT $ \rq -> do
 case mbU of
   Nothing -> errW "Not logged in" rq
   Just olduser@(User uname p cp js) -> do
     let newuser = User uname p cp (newjob:js)
     update (UpdateUser olduser newuser)
     let newrglobs = RenderGlobals ts (Just $ User uname p cp (newjob:js) )
     unServerPartT ( pageMyJobPosts newrglobs ) rq 
  ]
  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"

data NewUserInfo = NewUserInfo String String String
instance FromData NewUserInfo where
    fromData = liftM3 NewUserInfo (look "username")
                                  (look "password" `mplus` return "nopassword")
                                  (look "password2" `mplus` return "nopassword2")


-- newUserPage :: RenderGlobals -> ServerPartT IO Response
newUserPage rglobs =
  withData $ \(NewUserInfo user pass1 pass2) -> 
    [ ServerPartT $ \rq -> 
            if pass1 == pass2 
               then do exists <- query $ IsUser user
                       if exists
                            then errW "User already exists" rq
                            else do
                              update $ ( AddUser user pass1 )
                              mbU <- query (GetUser user)
                              case mbU of
                                Nothing -> errW "newUserPage, update failed" rq
                                Just u -> startsess rglobs u
               else errW "passwords did not match" rq
    ]
    where errW msg rq = ( return . tutlayoutU rglobs [("errormsgRegister", msg)] ) "register" 




-- check if a username and password is valid. If it is, return the user as successful monadic value
-- otherwise fail monadically
authUser :: Monad m => String -> String -> WebT IO (m User)
authUser name pass = do
  mbUser <- query (GetUser name)
  case mbUser of
    Nothing -> return . fail $ "login failed"
    (Just u) -> do
       p <- return . password $ u
       if p == (scramblepass pass)
         then return . return $ u
         else return . fail $ "login failed"

-- to do: make it so keeps your current page if you login/logout
-- probably modify RenderGlobals to keep track of that bit of state
startsess :: RenderGlobals -> User -> WebT IO Response
startsess (RenderGlobals ts _) user = do
  key <- update $ NewSession (SessionData $ username user)
  addCookie (3600) (mkCookie "sid" (show key))
  let newRGlobs = RenderGlobals ts (Just user) 
  (return . tutlayoutU newRGlobs [] ) "home"