version 1.0
[asp-class-generator:asp-class-generator.git] / Handler / User.hs
1 {-# LANGUAGE TemplateHaskell, OverloadedStrings, CPP #-}
2 module Handler.User where
3
4 import Yesod
5 import Control.Applicative
6 import Control.Monad(unless)
7
8 import ASPClassGenerator
9
10 #define debugRunDB debugRunDBInner __FILE__ __LINE__
11
12 userFormlet :: Maybe User -> Form s m User
13 -- Same as: paramsFormlet :: Formlet s m Params
14 userFormlet u = fieldsToTable $ User
15     <$> stringField "Full name" (fmap userFullName u)
16     -- <*> maybeStringField "Password" (fmap userPassword u)
17     <*> pure Nothing
18     <*> maybeStringField "int conversion function" (fmap userIntConvFunction u)
19     <*> maybeStringField "string conversion function" (fmap userStringConvFunction u)
20     <*> maybeStringField "float conversion function" (fmap userFloatConvFunction u)
21     <*> maybeStringField "object conversion function" (fmap userObjectConvFunction u)
22     <*> maybeStringField "date conversion function" (fmap userDateConvFunction u)
23     <*> maybeStringField "long conversion function" (fmap userLongConvFunction u)
24    -- <*> stringField "Password" (fmap userPassword u )
25
26 getProfileR :: Handler RepHtml
27 getProfileR = do
28     (uid, u) <- requireAuth
29     (res, form, enctype) <- runFormPostNoNonce $ userFormlet (Just u)
30     -- musername <- fmap (fmap snd) $ runDB $ getBy $ UniqueUsernameUser uid
31     case res of
32         FormSuccess u' -> do
33             runDB $ replace uid u'
34             setMessage "Updated your profile"
35             redirect RedirectTemporary ProfileR 
36         _ -> return ()
37     y <- getYesod
38     idents <- runDB $ selectList [IdentUserEq uid] [IdentIdentAsc] 0 0
39     defaultLayout $ do
40         setTitle "Edit Your Profile"
41         addCassius $(cassiusFile "profile")
42         --addJulius $(juliusFile "profile")
43         $(hamletFile "profile")
44     where
45         notOne [_] = False
46         notOne _ = True
47
48 postProfileR :: Handler RepHtml
49 postProfileR = getProfileR
50
51 postDeleteProfileR :: Handler RepHtml
52 postDeleteProfileR = undefined
53
54 postUserAddR :: Handler RepHtml
55 postUserAddR = getUserAddR
56
57 getUserAddR :: Handler RepHtml
58 getUserAddR = do
59     (uid, u) <- requireAuth
60     (res, form, enctype) <- runFormPostNoNonce $ userFormlet (Just u)
61     -- musername <- fmap (fmap snd) $ runDB $ getBy $ UniqueUsernameUser uid
62     case res of
63         FormSuccess u' -> do
64             uid' <- runDB $ insert u'
65             setMessage "Added user"
66             redirect RedirectTemporary ProfileR 
67         _ -> return ()
68     y <- getYesod
69     idents <- runDB $ selectList [IdentUserEq uid] [IdentIdentAsc] 0 0
70     defaultLayout $ do
71         setTitle "Add User"
72         --addCassius $(cassiusFile "profile")
73         --addJulius $(juliusFile "profile")
74         $(hamletFile "profile")
75     where
76         notOne [_] = False
77         notOne _ = True
78
79 postDeleteIdentR :: IdentId -> Handler ()
80 postDeleteIdentR iid = do
81     (uid, _) <- requireAuth
82     i <- debugRunDB $ get404 iid
83     unless (uid == identUser i) notFound
84     idents <- debugRunDB $ count [IdentUserEq uid]
85     if idents > 1
86         then do
87             debugRunDB $ delete iid
88             setMessage "Identifier deleted"
89         else setMessage "You cannot delete your last identifier"
90     redirect RedirectTemporary ProfileR
91