happs-tutorial-0.4: src/AppStateSetBased.hs

{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, 
             MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,
             TypeSynonymInstances, PatternSignatures #-}

module AppStateSetBased where  

import qualified Data.Map as M
import qualified Data.Set as S
import Data.List

import Control.Monad.Reader
import Control.Monad.State (modify,put,get,gets)
import Data.Generics
import HAppS.State
import SerializeableSessions
import SerializeableUsers
import Misc
--import Data.Graph.Inductive

-- Think of appdatastore as the database in a traditional web app.
-- Data there gets stored permanently
-- Data in appsessions is stored permanently too, but we don't care as much about its persistence,
-- it's just to keep track of who is logged in at a point in time.
-- appsessions field could be less complicated, just have M.Map Int SessionData
-- don't really see the advantage of declaring a wrapper over map.
data AppState = AppState {
  appsessions :: Sessions SessionData,  
  appdatastore :: S.Set User
} deriving (Show,Read,Typeable,Data)                                                        

instance Version AppState

$(deriveSerialize ''AppState) 

instance Component AppState where 
  type Dependencies AppState = End 
  initialValue = AppState { appsessions = (Sessions M.empty),
                         appdatastore = S.empty }


askDatastore :: Query AppState (S.Set User)                                    
askDatastore = do
  (s :: AppState ) <- ask
  return . appdatastore $ s


askSessions :: Query AppState (Sessions SessionData)
askSessions = return . appsessions =<< ask



modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()
modUsers f = modify (\s -> (AppState (appsessions s) (f $ appdatastore s)))                              

modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update AppState ()
modSessions f = modify (\s -> (AppState (f $ appsessions s) (appdatastore s)))                           

isUser :: String -> Query AppState Bool
isUser name = do
  return . (S.member name) . (setmap username) =<< askDatastore

-- I tried to declare a functor instance for Set a but got blocked.
setmap f = S.fromList . map f . S.toList

updateUser olduser newuser = modUsers $ updateUserPure olduser newuser
updateUserPure o n users | username o == username n = S.insert n . S.delete o $ users
                         | otherwise = error "updateUser, username is not allowed to change"
{-
changeConsultantProfile olduser newcp = modUsers $ changeConsultantProfilePure olduser newcp
changeConsultantProfilePure olduser@(User u p mbCP mbJobs ) newcp users =
  S.insert (User u p newcp mbJobs ) . S.delete olduser $ users
-}

addUser :: String -> String -> Update AppState ()
addUser name pass = modUsers $ S.insert (User name (scramblepass pass) cp []) 
  where cp = ConsultantProfile "" "" False
changePassword :: User -> String -> String -> Update AppState ()
changePassword u oldpass newpass = modUsers $ changepasswordPure u oldpass newpass



-- modify is simply delete plus insert 
changepasswordPure :: User -> String -> String -> S.Set User -> S.Set User
changepasswordPure olduser@(User u realoldpass mbCP mbJobs ) inputtedOldpass inputtedNewpass users = 
   let hashedoldpass = scramblepass inputtedOldpass
       hashednewpass = scramblepass inputtedNewpass
       
   in if (realoldpass /= hashedoldpass)
     then users
     else do S.insert (User u hashednewpass mbCP mbJobs ) . S.delete olduser $ users

getUser :: String -> Query AppState (Maybe User)
getUser u = return . lookupUserByName u =<< askDatastore

lookupUserByName :: String -> S.Set User -> Maybe User
lookupUserByName u users = lookupUser ((==u) . username) users

-- list the job along with the username who posted the job
listAllJobs :: Query AppState [(Job,String)]
listAllJobs = liftM alljobs askDatastore
  where alljobs users = concatMap userJobs . S.toList $ users
        userJobs (User n _ _ js) = map (\j -> (j,n)) js 
  

lookupUser f users = find f . S.toList $ users
listUsers :: Query AppState [String]
listUsers = liftM (map username . S.toList) askDatastore

--listUsersWantingDevelopers = liftM (map username . filter wantingDeveloper . S.toList) askDatastore
--  where wantingDeveloper u = not . null . jobs $ u

newSession :: SessionData -> Update AppState SessionKey
newSession u = do
  key <- getRandom
  modSessions $ Sessions . (M.insert key u) . unsession
  return key

delSession :: SessionKey -> Update AppState ()
delSession sk = modSessions $ Sessions . (M.delete sk) . unsession


getSession::SessionKey -> Query AppState (Maybe SessionData)
getSession key = liftM (M.lookup key . unsession) askSessions

numSessions :: Query AppState Int
numSessions  =  liftM (M.size . unsession) askSessions


                    


--------------dummy data

datastoreDummyData :: S.Set User
datastoreDummyData = S.fromList [
  User "tphyahoo" (scramblepass "password") tphyahooProfile tphyahooJobs
  , User "zzz" (scramblepass "password") (ConsultantProfile "" "" False) serpinskiJobs
  ] 

tphyahooProfile = ConsultantProfile {
  --billing_rate = "it depends on the project"
  contact = "thomashartman1 at gmail, +48 51 365 3957"
  -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.
  , blurb = "I'm currently living in poland, doing a software sabbatical where I'm \
             \learning new things and writing and releasing open source software, including this tutorial."
  , consultant = True 
}

tphyahooJobs = map (\(j,b)-> Job { jobname = j, jobbudget = b, jobblurb ="make " ++ j ++ " using HAppS "} ) $
             [ ("darcshub", "$5000")
              , ("community wizard", "$500,000")
              , ("hpaste in happs", "karma points?")
              , ("facebook clone", "$10,000")
              , ("rentacoder clone", "12,000 Eu")
              , ("ebay clone", "")
              , ("reddit clone", "")
              , ("ripplepay clone", "best offer")
              , ("oscommerce clone", "$1500")
              , ("phpbb clone", "")
              , ("sql-ledger clone", "")]
serpinskiJobs =  map (\num -> ( Job ("job" ++ (show num)) "$0" "") ) [10..203]

-- create dummy data

initializeDummyData = modUsers g
  where g users = if ( S.null users)
                    then datastoreDummyData
                    else error failmsg
        failmsg = "initializeDummyData, for safety, only works if there is currently no data in app\
                   \Maybe you shouldd first do mv _local _local.bak to get any existing data out of the way."


-- define types which are upper case of methods below, eg AddUser, AuthUser...
-- these types work with HApppS query/update machinery
-- in ghci, try :i AddUser
$(mkMethods ''AppState
    ['askDatastore
     , 'getUser        
     , 'addUser
     , 'changePassword     
     , 'updateUser
     , 'isUser
     , 'listUsers     
     , 'listAllJobs
     , 'getSession
     , 'newSession
     , 'delSession
     , 'numSessions
     , 'initializeDummyData]
 )