AppState1.hs

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, NoMonomorphismRestriction, ScopedTypeVariables,
    TypeFamilies, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances #-}
module StateVersions.AppState1 {- (
  module SerializeableUserInfos,
  Users (..), UserName -- , add_user_job
  
) -} where
import HAppS.State
import Data.Generics
import Control.Monad (liftM)
import Control.Monad.Reader (ask)
import Control.Monad.State (modify,put,get,gets)
import Data.Maybe
import Data.List

import qualified MiscMap as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

import Misc

t = let f (JobName (j :: B.ByteString)) = B.unpack j in f . JobName $ (B.pack "job")
-- It might be a bit of overkill to declare things with this level of specificity
-- but I think it'll make the type signatures easier to read later on.
newtype JobName = JobName { unjobname :: B.ByteString }
  deriving (Show,Read,Ord, Eq, Typeable,Data)

instance Version JobName
$(deriveSerialize ''JobName) 

data Job = Job {jobbudget :: B.ByteString -- we allow jobs with unspecified budgets
                , jobblurb :: B.ByteString}
  deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version Job
$(deriveSerialize ''Job) 

-- because Haskell records are a kludge, define mutator functions. bleh. oh well.
-- mod_field takes a mutator function
-- set_field takes a value
set_jobbudget = mod_jobbudget . const
mod_jobbudget f (Job bud blu) = Job (f bud) blu

set_jobblurb = mod_jobblurb . const 
mod_jobblurb f (Job bud blu) = Job bud (f blu)

newtype Jobs = Jobs { unjobs :: M.Map JobName Job }
  deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version Jobs
$(deriveSerialize ''Jobs) 

--import SerializeableUserInfos

--import SerializeableJobs


data UserProfile = UserProfile {
  --billing_rate :: String -- eg "" (blank is ok), "$30-$50/hour", "40-50 Euro/hour", "it depends on the project", etc.
  contact :: B.ByteString -- eg, "thomashartman1 at gmail, 917 915 9941"
  -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.
  , blurb :: B.ByteString
  , consultant :: Bool -- this is what actually determines whether the profile will list as a consultant or not
  , avatar :: B.ByteString -- path to an image file
} deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version UserProfile
$(deriveSerialize ''UserProfile) 

--mutators
set_contact = mod_contact . const
mod_contact f (UserProfile contact blurb consultant avatar) = UserProfile (f contact) blurb consultant avatar

set_blurb = mod_blurb . const
mod_blurb f (UserProfile contact blurb consultant avatar) = UserProfile contact (f blurb) consultant avatar

set_consultant = mod_consultant . const
mod_consultant f (UserProfile contact blurb consultant avatar) = UserProfile contact blurb (f consultant) avatar

data UserInfos = UserInfos {   
  password :: B.ByteString
  , userprofile :: UserProfile
  , jobs :: Jobs
} deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version UserInfos
$(deriveSerialize ''UserInfos) 


-- as a security measure, require that oldpass agrees with real old pass
set_password oldpass newpass (UserInfos pass up jobs) | pass == oldpass = return $ UserInfos newpass up jobs
                                              | otherwise = fail $ "bad old password: " 

-- mod_password f (UserInfos pass up jobs) = UserInfos (f pass) up jobs
set_userprofile = mod_userprofile . const
mod_userprofile f (UserInfos pass up jobs) = UserInfos pass (f up) jobs
-- set_jobs = mod_jobs . const
add_job jobname job =  mod_jobs $ M.insertUqM jobname job
del_job jobname = mod_jobs $ M.deleteM jobname

set_job = mod_job . const
mod_job f jobname = mod_jobs $ M.adjustM jobname f 
mod_jobs mf (UserInfos pass up (Jobs jobs) ) = either (fail . ("mod_jobs: " ++) )
                                                      (\js -> return $ UserInfos pass up (Jobs js) )
                                                      (mf jobs)



newtype UserName = UserName { unusername :: B.ByteString }
  deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version UserName
$(deriveSerialize ''UserName)

data Users = Users { users :: M.Map UserName UserInfos }
  deriving (Show,Read,Ord, Eq, Typeable,Data)
instance Version Users
$(deriveSerialize ''Users)

-- can fail monadically if the username doesn't exist, or the job name is a duplicate
add_user_job un jn job = mod_userMM un $ add_job jn job


-- adjust users, where the adjustment function can fail monadically
-- mod_userMM :: (Monad m) => UserName -> (UserInfos -> Either [Char] UserInfos) -> Users -> m Users
mod_userMM username f (Users us) = either (fail . ("mod_userMM: " ++) )
                                        (return . Users)
                                        (M.adjustMM username f us)

-- adjust users, where the adjustment function is presumed to be infallible,
-- but can still fail monadically if the username is invalid
mod_userM username f (Users us) = return . Users =<< M.adjustM username f us

set_user_userprofile_contact username c = mod_userM username $ ( mod_userprofile . set_contact $ c )
set_user_userprofile_blurb username b = mod_userM username $ ( mod_userprofile . set_blurb $ b )
set_user_userprofile_consultant username isconsultant =
  mod_userM username $ ( mod_userprofile . set_consultant $ isconsultant )

-- fails monadically if oldpass doesn't match password in user profile, via set_password
set_user_password :: (Monad m) => UserName -> B.ByteString -> B.ByteString -> Users -> m Users
set_user_password username oldpass newpass = mod_userMM username $ set_password oldpass newpass

-- set_user_userprofile username p = mod_userM username $ Right . set_userprofile p 

add_user username hashedpass (Users us)
    | B.null . unusername $ username = fail "blank username"
    | B.null hashedpass = fail "error: blank password"
    | not . isalphanum_S . B.unpack . unusername $ username
        = fail $ "bad username, " ++ allowedCharactersSnip
    | otherwise = either (fail . ("add_user: " ++))
                         (return . Users)
                         ( M.insertUqM username uis us )
  where uis = UserInfos hashedpass (UserProfile (B.pack "") (B.pack "")
                                                False (B.pack "") )
                                   (Jobs $ M.empty)

del_user username uis (Users us) = either (fail . ("del_user: " ++))
                                        (return . Users)
                                        ( M.deleteM username us )


type SessionKey = Integer                                                                   
newtype SessionData = SessionData {                                                            
  sesUser :: UserName
} deriving (Read,Show,Eq,Typeable,Data,Ord)
instance Version SessionData 
$(deriveSerialize ''SessionData)




data Sessions a = Sessions {unsession::M.Map SessionKey a}                                  
  deriving (Read,Show,Eq,Typeable,Data)
instance Version (Sessions a)
$(deriveSerialize ''Sessions)


-- 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.

-- to do: appdatastore should be :: Map UserName User
-- User :: Password ConsultantProfile Jobs
-- Jobs :: Map JobName Job
-- Job :: JobBudget JobBlurb
-- thereafter.......... 


data AppState = AppState {
  appsessions :: Sessions SessionData,  
  appdatastore :: Users
} 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 = Users M.empty }


-- myupdate field newval record = record { field = newval }

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


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

setUserProfile :: UserName -> UserProfile -> Update AppState ()
setUserProfile uname newprofile = modUserInfos uname $ set_userprofile newprofile

-- addJob :: UserName -> JobName -> Job -> Update AppState (Either String ())
addJob uname jn j = modUserInfosM uname $ add_job jn j


-- delJob :: UserName -> JobName -> Update AppState (Either String ())
delJob uname jn = modUserInfosM uname $ del_job jn 


setJob uname jn j = modUserInfosM uname $ set_job j jn

modUserInfosM :: UserName -> (UserInfos -> Either String UserInfos) -> Update AppState (Either String ())
modUserInfosM un mf = do
  (AppState sessions (Users users)) <- get
  case (M.adjustMM un mf users) of
    Left err -> return . Left $ err
    Right um -> do put $ AppState sessions (Users um)
                   return . Right $ ()

modUserInfos :: UserName -> ( UserInfos -> UserInfos ) -> Update AppState ()
modUserInfos un f = do 
  (AppState sessions (Users users)) <- get
  case (M.adjustM un f users) of
    Left err -> fail err
    Right um -> put $ AppState sessions (Users um)





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

-- yecchh.
-- the way setmap is being used seems kludgy
-- should probably either be using HAppS IndexSet, or a Map instead of Set.

isUser :: UserName -> Query AppState Bool
isUser name = do
  (Users us ) <- return . appdatastore =<< ask
  if (isJust $ M.lookup name us)
    then return True
    else return False

{-
addUser :: UserName -> B.ByteString -> Update AppState ()
addUser un@(UserName name) hashedpass = do
  AppState s us <- get
  case ( add_user un hashedpass us :: Either String Users) of
    Left err -> fail $ "addUser, name: " ++ (B.unpack name)
    Right newus -> put $ AppState s newus
-}

addUser :: UserName -> B.ByteString -> Update AppState (Either String ())
addUser un@(UserName name) hashedpass = do
  AppState s us <- get
  case ( add_user un hashedpass us :: Either String Users) of
    Left err -> if isInfixOf "duplicate key" err
                  then return . Left $ "username taken"
                  else return . Left $ "error: " ++ err
    Right newus -> do put $ AppState s newus
                      return $ Right ()


changePassword :: UserName -> B.ByteString -> B.ByteString -> Update AppState ()
changePassword un oldpass newpass = do
  AppState s us <- get
  case ( set_user_password un (B.pack hashedoldpass) (B.pack hashednewpass) us :: Either String Users) of
    Left err -> fail $ "changePassword"
    Right newus -> put $ AppState s us
  where hashedoldpass = scramblepass (B.unpack oldpass)
        hashednewpass = scramblepass (B.unpack newpass)


-- was getUser
getUserInfos :: UserName -> Query AppState (Maybe UserInfos)
getUserInfos u = ( return . M.lookup u . users ) =<< askDatastore

getUserProfile u = do
  mbUI <- getUserInfos u
  case mbUI of 
    Nothing -> return Nothing
    Just (UserInfos pass profile jobs) -> return $ Just profile

-- list all jobs along with the username who posted each job
-- listAllJobs :: Query AppState (M.Map UserName Jobs)
listAllJobs = return .
                  concat . M.elems
                    . M.mapWithKey g                 
                       . M.map (unjobs . jobs) . users 
                           =<< askDatastore 
  where g uname jobs = map ( \(jobname,job) -> (jobname,job,uname) ) . M.toList $ jobs


-- lookupUser f users = find f . S.toList $ users
listUsers :: Query AppState [UserName]
listUsers = ( return . M.keys . users ) =<< askDatastore

listUsersWantingDevelopers =  (return . M.keys . M.filter wantingDeveloper . users) =<< askDatastore
  where wantingDeveloper uis = not . M.null . unjobs . jobs $ uis



newSession :: SessionData -> Update AppState SessionKey
newSession u = do  
  AppState (Sessions ss) us <- get
  (newss,k) <- inssess u ss  
  -- check that random session key is really unique
  --modSessions $ Sessions . (M.insert key u) . unsession
  put $ AppState (Sessions newss) us
  return k
  where
    inssess u sessions = do
      key <- getRandom
      case (M.insertUqM key u sessions) of
        Nothing -> inssess u sessions
        Just m -> return (m,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

-- initializeDummyData dd = modUsers (const dd)
initializeDummyData dd = do
  AppState ss (Users us) <- get
  if M.null us 
    then fail "initializeDummyData, users not empty"
    else put $ AppState ss (Users dd)

-- bad performance for large unumbers of users (>1000, with 200 jobs/dummy user)
-- maybe macid doesn't like serializing large quantities of data at once
addDummyData dd = do
  AppState ss (Users us) <- get
  put $ AppState ss (Users (M.union us dd) )

addDummyUser (un,uis) = do
  AppState ss (Users us) <- get
  us' <- M.insertUqM un uis us
  put $ AppState ss (Users us' )


-- 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
     , 'getUserInfos
     , 'getUserProfile
     , 'addUser
     , 'changePassword 
     , 'setUserProfile
     -- , 'updateUser
     , 'isUser
     , 'listUsers     
     , 'listAllJobs
     , 'getSession
     , 'newSession
     , 'delSession
     , 'numSessions
     , 'initializeDummyData
     , 'addDummyData
     , 'addDummyUser
     , 'addJob
     , 'delJob
     , 'setJob ]
 )