diff options
| -rw-r--r-- | database-shm | bin | 0 -> 32768 bytes | |||
| -rw-r--r-- | database-wal | bin | 0 -> 6320 bytes | |||
| -rw-r--r-- | src/server/Controller/SignIn.hs | 16 | ||||
| -rw-r--r-- | src/server/Controller/User.hs | 25 | ||||
| -rw-r--r-- | src/server/Main.hs | 9 | ||||
| -rw-r--r-- | src/server/Model/Database.hs | 4 | ||||
| -rw-r--r-- | src/server/Model/Income.hs | 21 |
7 files changed, 60 insertions, 15 deletions
diff --git a/database-shm b/database-shm Binary files differnew file mode 100644 index 0000000..494f47a --- /dev/null +++ b/database-shm diff --git a/database-wal b/database-wal Binary files differnew file mode 100644 index 0000000..4d24ee6 --- /dev/null +++ b/database-wal diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 955ad35..3bbb9ff 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -64,22 +64,22 @@ errorResponse msg = do jsonObject [("error", Json.String msg)] validateSignIn :: Config -> Text -> ActionM () -validateSignIn config token = do - maybeSignIn <- liftIO . runDb $ getSignInToken token +validateSignIn config textToken = do + mbToken <- liftIO . runDb $ getSignInToken textToken now <- liftIO getCurrentTime - case maybeSignIn of - Just signIn -> - if signInIsUsed . entityVal $ signIn + case mbToken of + Just token -> + if signInIsUsed . entityVal $ token then redirectError (getMessage SignInUsed) else - let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn) + let diffTime = now `diffUTCTime` (signInCreation . entityVal $ token) in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60) then redirectError (getMessage SignInExpired) else do - LoginSession.put (signInEmail . entityVal $ signIn) - liftIO . runDb . signInTokenToUsed . entityKey $ signIn + LoginSession.put (signInEmail . entityVal $ token) + liftIO . runDb . signInTokenToUsed . entityKey $ token redirect "/" Nothing -> redirectError (getMessage SignInInvalid) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs index bc99ea5..420a2d9 100644 --- a/src/server/Controller/User.hs +++ b/src/server/Controller/User.hs @@ -4,12 +4,17 @@ module Controller.User ( getUsers , whoAmI , getIncome + , setIncome ) where import Web.Scotty +import Network.HTTP.Types.Status (ok200) + import Control.Monad.IO.Class (liftIO) +import Database.Persist + import qualified Data.Aeson.Types as Json import qualified Secure @@ -18,21 +23,33 @@ import Json (jsonObject) import Model.Database import qualified Model.User as U +import qualified Model.Income as I getUsers :: ActionM () getUsers = - Secure.loggedAction (\_ -> do + Secure.loggedAction (\_ -> (liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json ) whoAmI :: ActionM () whoAmI = - Secure.loggedAction (\user -> do + Secure.loggedAction (\user -> json (U.getJsonUser user) ) getIncome :: ActionM () getIncome = - Secure.loggedAction (\_ -> do - jsonObject [] + Secure.loggedAction (\user -> do + mbIncome <- liftIO . runDb . I.getIncome $ entityKey user + case mbIncome of + Just income -> + jsonObject [("income", Json.Number . fromIntegral . incomeAmount $ income)] + Nothing -> + jsonObject [] + ) + +setIncome :: Int -> ActionM () +setIncome amount = + Secure.loggedAction (\user -> + (liftIO . runDb $ I.setIncome (entityKey user) amount) >> status ok200 ) diff --git a/src/server/Main.hs b/src/server/Main.hs index 8956fa4..71c4674 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -48,9 +48,12 @@ main = do -- Users - get "/users" getUsers - get "/whoAmI" whoAmI - get "/income" getIncome + get "/users" getUsers + get "/whoAmI" whoAmI + get "/income" getIncome + post "/income" $ do + amount <- param "amount" :: ActionM Int + setIncome amount -- Payments diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 0bbc353..c88322f 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -52,6 +52,10 @@ Job lastExecution UTCTime Maybe UniqJobName kind deriving Show +Income + userId UserId + creation UTCTime + amount Int |] type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs new file mode 100644 index 0000000..edf1c92 --- /dev/null +++ b/src/server/Model/Income.hs @@ -0,0 +1,21 @@ +module Model.Income + ( getIncome + , setIncome + ) where + +import Data.Time.Clock (getCurrentTime) + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist + +import Model.Database + +getIncome :: UserId -> Persist (Maybe Income) +getIncome userId = + fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation] + +setIncome :: UserId -> Int -> Persist IncomeId +setIncome userId amount = do + now <- liftIO getCurrentTime + insert (Income userId now amount) |