diff --git a/Handler/Home.hs b/Handler/Home.hs index 7ec6ce1..04653f5 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -16,8 +16,8 @@ module Handler.Home where import Import -import qualified Text.Read as R import Data.Maybe +import Data.Time.Calendar (addDays) -- This is a handler function for the GET request method on the HomeR -- resource pattern. All of your resource patterns are defined in @@ -29,17 +29,15 @@ import Data.Maybe getHomeR :: Handler Html getHomeR = do beverages <- runDB $ selectList [BeverageAmount !=. 0] [Desc BeverageIdent] - time <- liftIO getCurrentTime - let secs = R.read (formatTime defaultTimeLocale "%s" time) - 2592000 - users <- runDB $ selectList [UserTimestamp >=. secs] [Asc UserIdent] + today <- liftIO $ return . utctDay =<< getCurrentTime + users <- runDB $ selectList [UserTimestamp >=. addDays (-30) today] [Asc UserIdent] defaultLayout $ $(widgetFile "home") getReactivateR :: Handler Html getReactivateR = do - time <- liftIO getCurrentTime - let secs = R.read (formatTime defaultTimeLocale "%s" time) - 2592000 - users <- runDB $ selectList [UserTimestamp <. secs] [Asc UserIdent] + today <- liftIO $ return . utctDay =<< getCurrentTime + users <- runDB $ selectList [UserTimestamp <. addDays (-30) today] [Asc UserIdent] defaultLayout $ $(widgetFile "reactivate") @@ -48,9 +46,8 @@ getUserReactivateR uId = do mUser <- runDB $ get uId case mUser of Just _ -> do - time <- liftIO getCurrentTime - let secs = R.read $ formatTime defaultTimeLocale "%s" time - runDB $ update uId [UserTimestamp =. secs] + today <- liftIO $ return . utctDay =<< getCurrentTime + runDB $ update uId [UserTimestamp =. today] setMessageI MsgUserReactivated redirect HomeR Nothing -> do diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index 2a6a1af..d7e2e50 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -17,26 +17,23 @@ module Handler.NewUser where import Import as I import Handler.Common -import Text.Read import Text.Shakespeare.Text getNewUserR :: Handler Html getNewUserR = do - time <- liftIO getCurrentTime - let secs = read $ formatTime defaultTimeLocale "%s" time + today <- liftIO $ return . utctDay =<< getCurrentTime (newUserWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm - $ newUserForm secs + $ newUserForm today defaultLayout $ $(widgetFile "newUser") postNewUserR :: Handler Html postNewUserR = do - time <- liftIO getCurrentTime - let secs = read $ formatTime defaultTimeLocale "%s" time + today <- liftIO $ return . utctDay =<< getCurrentTime ((res, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm - $ newUserForm secs + $ newUserForm today case res of FormSuccess user -> do namesakes <- runDB $ selectList [UserIdent ==. userIdent user] [] @@ -52,11 +49,11 @@ postNewUserR = do setMessageI MsgUserNotCreated redirect NewUserR -newUserForm :: Int -> AForm Handler User -newUserForm secs = User +newUserForm :: Day -> AForm Handler User +newUserForm today = User <$> areq textField (bfs MsgName) Nothing <*> pure 0 - <*> pure secs + <*> pure today <*> aopt emailField (bfs MsgEmailNotify) Nothing <*> aopt (selectField avatars) (bfs MsgSelectAvatar) Nothing <* bootstrapSubmit (msgToBSSubmit MsgSubmit) diff --git a/config/models b/config/models index c12e0b8..c70e1c0 100644 --- a/config/models +++ b/config/models @@ -1,7 +1,7 @@ User ident Text balance Int - timestamp Int + timestamp Day email Text Maybe avatar AvatarId Maybe UniqueUser ident