{-# 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)