happs-tutorial-0.8: src/ControllerPostActions.hs

{-# LANGUAGE ScopedTypeVariables #-}
module ControllerPostActions where

import Data.List (isInfixOf)
import qualified Data.ByteString.Char8 as B
import Control.Monad.Error


import Happstack.Server
import Happstack.State
import Happstack.Helpers

import StateVersions.AppState1
import View
import Misc
import ControllerMisc
import ControllerGetActions
import FromDataInstances


loginPage :: RenderGlobals -> ServerPartT IO Response
loginPage rglobs@(RenderGlobals rq _ _) = 
  -- unfortunately can't just use rqUrl rq here, because sometimes has port numbers and... it gets complicated
  case tutAppReferrer rq of
    Left e -> errW rglobs e
    Right landingpage -> loginPage' authUser startsess' rglobs landingpage 
  where 
    authUser = authUser' getUserPassword
    getUserPassword name = return . maybe Nothing (Just . B.unpack . password) =<< query (GetUserInfos name)

-- move this to HAppSHelpers
tutAppReferrer :: Request -> Either String String
tutAppReferrer rq = do
          let approot :: Either String String
              approot = modRewriteAppUrl "" rq 
          case approot of 
            Left _ -> Left $ "tutAppReferrer, could not determine approot, rq: " ++ (show rq)
            Right ar ->
              case getHeaderVal "referer" rq of 
                  Left e -> Left $ "smartAppReferrer error, rq: " ++ e
                  -- check against logout, otherwise if you have just logged out then 
                  -- try immediately to log in again it won't let you.
                  Right rf ->  if isInfixOf "logout" rf || isInfixOf "login" rf || isInfixOf "newuser" rf
                      then Right ar
                      else  Right rf

-- Use a helper function because the plan is to eventually have a similar function
-- that works for admin logins
loginPage' :: (Monad m) =>
              (UserName -> B.ByteString -> ServerPartT m Bool)
              -> (RenderGlobals -> UserName -> String -> ServerPartT m Response)
              -> RenderGlobals
              -> String
              -> ServerPartT m Response
loginPage' auth startsession rglobs landingpage =
  withData $ \(UserAuthInfo user pass) -> do
        loginOk <- auth user pass
        if loginOk
          then startsession rglobs user landingpage
          else errW rglobs "Invalid user or password" {- case ( modRewriteCompatibleTutPath rq ) of
            Left e -> errW rglobs e 
            Right p -> return $ tutlayoutU rglobs [("loginerrormsg","login error: invalid username or password")] p -}

-- check if a username and password is valid. If it is, return the user as successful monadic value
-- otherwise fail monadically
authUser' :: (UserName -> ServerPartT IO (Maybe String) ) -> UserName -> B.ByteString -> ServerPartT IO Bool
authUser' getpwd name pass = do
  mbP <- getpwd name
  -- scramblepass works with lazy bytestrings, maybe that's by design. meh, leave it for now
  -- to do: we need to use a seed, there was a discussion about this on haskell cafe.
  return $ maybe False ( == scramblepass (B.unpack pass) ) mbP


changePasswordSP :: RenderGlobals -> ServerPartT IO Response
changePasswordSP rglobs = withData $ \(ChangePasswordInfo newpass1 newpass2) ->
    if newpass1 /= newpass2 
      then return $ errw "new passwords don't match"
      else do 
        etRes <- runErrorT $ getLoggedInUserInfos rglobs
        case etRes of
          Left e -> return $ errw e
          Right (u,_) ->  do     
            -- newp <- newPassword (B.unpack newpass1)
            update $ ChangePassword u newpass1
            return $ tutlayoutU rglobs [] "accountsettings-changed"
  where errw msg = tutlayoutU rglobs [("errormsgAccountSettings", msg)] "changepassword"

processformEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response
processformEditConsultantProfile rglobs =
  withData $ \(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents) ->
 case (return . sesUser =<< mbSession rglobs) of
   Nothing -> errW rglobs "Not logged in"
   Just unB -> do
     mbUP <- query $ GetUserProfile unB
     case mbUP of
       Nothing -> errW rglobs "error retrieving user infos"
       Just (UserProfile _ _ _ pAvatar) -> do
         up <- if B.null (fdimagecontents)
           then return $ UserProfile fdContact fdBlurb fdlistAsC pAvatar
           else do
             let avatarpath = writeavatarpath unB
             -- to do: verify this handles errors, eg try writing to someplace we don't have permission,
             -- or a filename with spaces, whatever
             liftIO $ writeFileForce avatarpath fdimagecontents
             return $ UserProfile fdContact fdBlurb fdlistAsC (B.pack avatarpath)             
         update $ SetUserProfile unB up
         viewEditConsultantProfile rglobs

processformEditJob :: RenderGlobals -> ServerPartT IO Response
processformEditJob rglobs@(RenderGlobals _ _ mbSess) =
  withData $ \(EditJob jn jbud jblu) ->
  case (return . sesUser =<< mbSess) of
    Nothing -> errW rglobs "Not logged in" 
    -- Just olduser@(User uname p cp js) -> do
    Just uname ->
      if null (B.unpack . unjobname $ jn)
        then errW rglobs "error, blank job name"
        else do 
          update $ SetJob uname jn (Job (B.pack jbud) (B.pack jblu))
          viewEditJob uname jn rglobs

errW :: (Monad m) => RenderGlobals -> String -> m Response
errW rglobs msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"
        

processformNewJob :: RenderGlobals -> ServerPartT IO Response
processformNewJob rglobs@(RenderGlobals _ _ mbSess) =
  withData $ \(NewJobFormData jn newjob) ->
 case (return . sesUser =<< mbSess) of
   Nothing -> errW rglobs "Not logged in"
   Just user ->
     if null (B.unpack . unjobname $ jn)
        then errW rglobs "error, blank job name"
        else do 
         res <- update (AddJob user jn newjob)
         case res of 
           Left err -> case isInfixOf "duplicate key" (lc err) of
                              True -> errW rglobs "duplicate job name"
                              _ -> errW rglobs "error inserting job"
           Right () -> pageMyJobPosts rglobs


newUserPage :: RenderGlobals -> ServerPartT IO Response
newUserPage rglobs =
  withData $ \(NewUserInfo user (pass1 :: B.ByteString) pass2) -> do
      rq <- askRq
      etRes <- runErrorT $ 
        setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) 
      case etRes of
          Left err -> errW rglobs err 
          Right () -> case modRewriteAppUrl "tutorial/registered" rq of
                        Left e -> errW rglobs e
                        Right p -> startsess' rglobs user p
                         
  where
    setupNewUser :: NewUserInfo -> ErrorT [Char] (ServerPartT IO) ()
    setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) = do
        when (B.null pass1 || B.null pass2) (throwError "blank password")
        when (pass1 /= pass2) (throwError "passwords don't match")
          --  Q: can return . Left be replaced with throwError?
          --  A: no. But you can return just plain Left with throwError.
        nameTakenHAppSState <- query $ IsUser user
        when nameTakenHAppSState (throwError "name taken")
        addUserVerifiedPass user pass1 pass2

  

addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (ServerPartT IO) ()
addUserVerifiedPass user pass1 pass2 =
  ErrorT $ newuser user pass1 pass2
  where
    newuser :: UserName -> B.ByteString -> B.ByteString -> ServerPartT IO (Either String ())
    newuser u@(UserName _) p1 p2 -- userExists
      | p1 /= p2 = return . Left $  "passwords did not match"
      | otherwise = update $ AddUser u $ B.pack $ scramblepass (B.unpack p1)