happs-tutorial-0.6.4: src/ControllerPostActions.hs
{-# LANGUAGE ScopedTypeVariables #-}
module ControllerPostActions where
import Debug.Trace.Helpers
import Text.ParserCombinators.Parsec
import Control.Monad
import Control.Monad.Trans
import Data.List (isInfixOf)
import qualified Data.ByteString.Char8 as B
import Control.Monad.Error
import System.FilePath (takeFileName)
import HAppS.Server
import HAppS.State
import HAppS.Helpers
import StateVersions.AppState1
import View
import Misc
import ControllerMisc
import ControllerGetActions
import FromDataInstances
loginPage :: RenderGlobals -> ServerPartT IO Response
loginPage rglobs@(RenderGlobals rq _ _) = do
-- 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 -> do
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 -> WebT m Bool)
-> (RenderGlobals -> UserName -> String -> WebT m Response)
-> RenderGlobals
-> String
-> ServerPartT m Response
loginPage' auth startsession rglobs landingpage =
withData $ \(UserAuthInfo user pass) ->
[ ServerPartT $ \rq -> 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 -> WebT IO (Maybe String) ) -> UserName -> B.ByteString -> WebT 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 rglobs = withData $ \(ChangeUserInfo oldpass newpass1 newpass2) -> [ ServerPartT $ \rq -> do
etRes <- runErrorT $ getLoggedInUserInfos rglobs
case etRes of
Left e -> errW e
Right (u,_) -> do
if newpass1 /= newpass2
then errW "new passwords did not match"
else do update $ ChangePassword u oldpass newpass1
return $ tutlayoutU rglobs [] "accountsettings-changed"
]
where errW msg = ( return . tutlayoutU rglobs [("errormsgAccountSettings", msg)] ) "changepassword"
processformEditConsultantProfile rglobs =
withData $ \fd@(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents) -> [ ServerPartT $ \rq -> do
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 pContact pBlurb listasC 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
unServerPartT ( viewEditConsultantProfile rglobs) rq
]
processformEditJob :: RenderGlobals -> ServerPartT IO Response
processformEditJob rglobs@(RenderGlobals rq ts mbSess) =
withData $ \(EditJob jn jbud jblu) -> [ ServerPartT $ \rq -> do
case (return . sesUser =<< mbSess) of
Nothing -> errW rglobs "Not logged in"
-- Just olduser@(User uname p cp js) -> do
Just uname -> do
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))
unServerPartT ( viewEditJob uname jn rglobs) rq
]
errW rglobs msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"
processformNewJob rglobs@(RenderGlobals rq ts mbSess) =
withData $ \(NewJobFormData jn newjob) -> [ ServerPartT $ \rq -> do
case (return . sesUser =<< mbSess) of
Nothing -> errW rglobs "Not logged in"
Just user -> do
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"
otherwise -> errW rglobs "error inserting job"
Right () -> unServerPartT ( pageMyJobPosts rglobs ) rq
]
newUserPage :: RenderGlobals -> ServerPartT IO Response
newUserPage rglobs =
withData $ \(NewUserInfo user (pass1 :: B.ByteString) pass2) ->
[ ServerPartT $ \rq -> do
etRes <- runErrorT $ do
setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2)
case etRes of
Left err -> errW rglobs err
Right () -> do case modRewriteAppUrl "tutorial/registered" rq of
Left e -> errW rglobs e
Right p -> startsess' rglobs user p
]
where
setupNewUser :: NewUserInfo -> ErrorT [Char] (WebT IO) ()
setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) = do
if B.null pass1 || B.null pass2
then throwError "blank password"
else return ()
if pass1 /= pass2
-- TITS: can return . Left be replaced with throwError?
-- A: no. But you can return just plain Left with throwError.
then throwError "passwords don't match"
else return ()
nameTakenHAppSState <- query $ IsUser user
if nameTakenHAppSState
then throwError "name taken"
else return ()
addUserVerifiedPass user pass1 pass2
addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (WebT IO) ()
addUserVerifiedPass user pass1 pass2 = do
ErrorT $ newuser user pass1 pass2
where
newuser :: UserName -> B.ByteString -> B.ByteString -> WebT IO (Either String ())
newuser u@(UserName us) pass1 pass2 -- userExists
| pass1 /= pass2 = return . Left $ "passwords did not match"
| otherwise = update $ AddUser u $ B.pack $ scramblepass (B.unpack pass1)