change timestamp format to day

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

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)

config/models

@@ -1,7 +1,7 @@
 User
     ident Text
     balance Int
-    timestamp Int
+    timestamp Day
     email Text Maybe
     avatar AvatarId Maybe
     UniqueUser ident