happs-tutorial-0.4.1: src/ControllerGetActions.hs

{-# LANGUAGE PatternSignatures, NoMonomorphismRestriction #-}
module ControllerGetActions where

import Control.Monad
import Control.Monad.Reader

import HAppS.Server

import ControllerMisc

import StateStuff
import ViewStuff
import Data.List
import qualified Data.Set as S

import Misc


-- This could be a lot less verbose, and use shorter variable names,
-- but it's the tutorial instructional example for using FromData to deal with forms, so no harm.
data JobsPaginationUrlData = JobsPaginationUrlData { jpCurrPage :: Int, jpResultsPerPage :: Int }
instance FromData JobsPaginationUrlData where
    fromData =
        let readerCurrpage,readerResultsPerPage :: ReaderT ([(String, Input)], [(String, Cookie)]) Maybe Int
            readerCurrpage = return . read -- convert string to int
                               =<< look "currentpage" `mplus` return "1" -- get string from urlencoded get string
            readerResultsPerPage = return . read =<< look "resultsPerPage" `mplus` return "10"               

            readerJobsPaginationUrlData :: ReaderT ([(String,Input)], [(String,Cookie)]) Maybe JobsPaginationUrlData
            readerJobsPaginationUrlData = liftM2 JobsPaginationUrlData readerCurrpage readerResultsPerPage
        in  readerJobsPaginationUrlData    


--viewJobs :: RenderGlobals -> Pagination -> [ServerPartT IO Response]
viewJobs rglobs  = withData $ \(JobsPaginationUrlData currP resPP) -> 
  [ ServerPartT $ \rq -> do 
  rsListAllJobs <- query ListAllJobs  
  let jobTable = paintAllJobsTable rglobs rsListAllJobs currP resPP
      -- if not logged in, you get invited to post a job,
      -- basically an incentive to register

      -- this next line should be coming from a template, and it's duplicated elsewhere, slightly bad.
      tmplattrs = maybe (def++[("postJob","post a HAppS job")]) (\_ -> def) (mbUser rglobs)
        where def = [("jobTable",  jobTable)]
  return . tutlayoutU rglobs tmplattrs $ "jobs"
  ]



data JobLookup = JobLookup {postedBy:: String, jobName :: String}
instance FromData JobLookup where
    fromData = liftM2 JobLookup (look "user")
                                (look "job")
viewJob rglobs  =
  withData $ \(JobLookup pBy jN) ->
    [ ServerPartT $ \rq -> do
        mbJ <- lookupJob pBy jN 
        case mbJ of
          Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"
          Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy j)] "viewjob"
     
    ]

lookupJob pBy jN = do
  appUsers <- query AskDatastore
  return $ do u <- find ( (==pBy) . username) . S.toList $ appUsers
              find ( (==jN) . jobname) $ jobs u



data UserNameUrlString = UserNameUrlString {profilename :: String}
instance FromData UserNameUrlString where
    fromData = liftM UserNameUrlString (look "user")

userProfile rglobs = 
  withData $ \(UserNameUrlString user) ->
    [ ServerPartT $ \rq -> do

        mbCP <- do mbU <- query (GetUser user)  
                   return $ do u <- mbU
                               return . consultantprofile $ u

        case mbCP of
          Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ user)] "viewconsultantprofile"
          Just cp  -> return . tutlayoutU rglobs [("cp",paintProfile rglobs user cp)] $ "viewconsultantprofile"
    ]



pageMyJobPosts rglobs = ServerPartT $ \rq -> do        
  let r = renderTemplateGroup (templates rglobs)
  case mbUser rglobs of
    Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"
    Just currU -> do
          let jobPostsTable = paintUserJobsTable rglobs (username currU) (jobs currU) 1 20
          return $ tutlayoutU rglobs [("jobPostsTable",jobPostsTable)] "myjobposts"

-- viewEditJob :: RenderGlobals -> ServerPartT IO Response        
viewEditJobWD rglobs = withData $ \(JobLookup pBy jN) -> [viewEditJob pBy jN rglobs]
deleteJobWD rglobs = withData $ \(JobLookup pBy jN) -> [deleteJob pBy jN rglobs]

-- there's a lot of repeated code for viewEdit and Delete of jobs. 
-- maybe can consolidate
deleteJob pBy jN rglobs = ServerPartT $ \rq -> do        
    case mbUser rglobs of
      Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"
      Just currU@(User n p cp js) -> do
        if (username currU) /= pBy
           then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]
                           "errortemplate"
           else do
             mbJ <- lookupJob pBy jN 
             case mbJ of
               Nothing -> return $ tutlayoutU rglobs
                            [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"
               Just j -> do -- deleting a job by filtering a list seems wrong.
                            -- probably should have used a Set rather than a list.
                            -- but whatever, it works.
                            let newjobs = filter (not . (==jN) . jobname) js
                                newuser = User n p cp newjobs
                            updateUserSp rglobs newuser pageMyJobPosts rq

viewEditJob pBy jN rglobs = ServerPartT $ \_ -> do        
    case mbUser rglobs of
      Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"
      Just currU -> do
        if (username currU) /= pBy
           then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]
                           "errortemplate"
           else do
             mbJ <- lookupJob pBy jN 
             case mbJ of
               Nothing -> return $ tutlayoutU rglobs
                            [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"
               Just j -> do let -- use show below to properly escape quotes
                                attrs = [ ("oldJobname", show . jobname $ j)
                                        , ("newJobname", show . jobname $ j)
                                        , ("budget", show . jobbudget $ j)
                                        , ("jobblurb", show . jobblurb $ j)
                                        , ("showJob",paintjob rglobs pBy j)
                                      ]
                            return $ tutlayoutU rglobs attrs "editjob" 



viewEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response        
viewEditConsultantProfile rglobs = ServerPartT $ \rq -> do        
  case mbUser rglobs of
    Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"
    Just currU -> do
      let cp = consultantprofile currU 
      let showPr = paintProfile rglobs (username currU) cp 
          listAsConsultantChecked = if consultant cp
                                      then "checked"
                                      else ""
          -- use show below to properly escape quotes
          attrs = [ ("blurb", show . blurb $ cp)
                        -- , ("jobsPosted",jobsPosted)
                        , ("contact",show . contact $ cp)
                        , ("listAsConsultantChecked", listAsConsultantChecked)
                        , ("profile",showPr)
                      ]
      return $ tutlayoutU rglobs attrs "editconsultantprofile"