From 520ab40070a793a5e7fd3a2b2d1666d29e30250a Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 14 Aug 2019 18:04:16 +0200 Subject: [PATCH] add files --- src/Control/Auth.hs | 34 +++++++++++++++ src/Control/Product.hs | 62 +++++++++++++++++++++++++++ src/Control/User.hs | 95 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 191 insertions(+) create mode 100644 src/Control/Auth.hs create mode 100644 src/Control/Product.hs create mode 100644 src/Control/User.hs diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs new file mode 100644 index 0000000..ae69f02 --- /dev/null +++ b/src/Control/Auth.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +module Control.Auth where + +import Servant + +import Control.Monad (void) + +import Control.Monad.Reader (ask) + +-- internal imports + +import Types +import Model + +authGet :: Int -> MateHandler AuthInfo +authGet id = + getUserAuthInfo id + +authSend :: AuthRequest -> MateHandler AuthResult +authSend = processAuthRequest + +authLogout :: Maybe Int -> Int -> MateHandler () +authLogout (Just muid) luid = do + if muid == luid + then + processLogout luid + else + throwError $ err403 + { errBody = "Forbidden" + } +authLogout Nothing _ = do + throwError $ err403 + { errBody = "Forbidden" + } diff --git a/src/Control/Product.hs b/src/Control/Product.hs new file mode 100644 index 0000000..ef36c95 --- /dev/null +++ b/src/Control/Product.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +module Control.Product where + +import Servant + +import Control.Monad (void) + +import Control.Monad.Reader (ask) + +-- internal imports + +import Types +import Model + +productNew :: Maybe Int -> ProductSubmit -> MateHandler Int +productNew (Just _) bevsub = do + conn <- rsConnection <$> ask + bevid <- insertProduct bevsub conn + void $ insertNewEmptyAmount bevid bevsub conn + return bevid +productNew Nothing _ = + throwError $ err403 + +productOverview :: Int -> MateHandler ProductOverview +productOverview pid = do + conn <- rsConnection <$> ask + productOverviewSelectSingle pid conn + +productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler () +productStockRefill (Just _) amorefs = do + if all ((>= 0) . amountRefillAmount) amorefs + then do + conn <- rsConnection <$> ask + void $ manualProductAmountRefill amorefs conn + else + throwError $ err406 + { errBody = "Amounts less than 0 are not acceptable" + } +productStockRefill Nothing _ = + throwError $ err403 + { errBody = "No Authentication present" + } + +productStockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler () +productStockUpdate (Just _) amoups = do + if all ((>= 0) . amountUpdateRealAmount) amoups + then do + conn <- rsConnection <$> ask + void $ manualProductAmountUpdate amoups conn + else + throwError $ err406 + { errBody = "Amounts less than 0 are not acceptable" + } +productStockUpdate Nothing _ = + throwError $ err403 + { errBody = "No Authentication present" + } + +productList :: MateHandler [ProductOverview] +productList = do + conn <- rsConnection <$> ask + productOverviewSelect conn diff --git a/src/Control/User.hs b/src/Control/User.hs new file mode 100644 index 0000000..e2595eb --- /dev/null +++ b/src/Control/User.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +module Control.User where + +import Servant + +import Control.Monad (void) + +import Control.Monad.Reader (ask) + +import Control.Monad.IO.Class (liftIO) + +import Data.Time (getCurrentTime, utctDay) + +import Data.ByteString.Random (random) + +import qualified Data.Text as T + +-- internal imports + +import Types +import Model + +userNew :: UserSubmit -> MateHandler Int +userNew us = do + now <- liftIO $ getCurrentTime + randSalt <- liftIO $ random 8 + conn <- rsConnection <$> ask + insertUser us (utctDay now) randSalt conn + +userGet :: Maybe Int -> Int -> MateHandler UserDetails +userGet Nothing _ = + throwError $ err403 + { errBody = "No Authentication present" + } +userGet (Just aid) id = + if aid == id + then do + now <- liftIO $ getCurrentTime + conn <- rsConnection <$> ask + -- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now)) + userDetailsSelect conn id + else + throwError $ err403 + { errBody = "Wrong Authentication present" + } + +userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler () +userUpdate Nothing _ _ = + throwError $ err403 + { errBody = "No Authentication present" + } +userUpdate (Just aid) id uds = + if aid == id + then do + now <- liftIO $ getCurrentTime + conn <- rsConnection <$> ask + void $ updateUserDetails id uds (utctDay now) conn + else + throwError $ err403 + { errBody = "Wrong Authentication present" + } + +userList :: Maybe Int -> Maybe Refine -> MateHandler [User] +userList muid ref = do + conn <- rsConnection <$> ask + userSelect conn ref + +userRecharge :: Maybe Int -> UserRecharge -> MateHandler () +userRecharge (Just auid) (UserRecharge uid amount) = + if auid == uid + then + if amount >= 0 + then do + conn <- rsConnection <$> ask + ud <- userDetailsSelect conn uid + void $ insertNewJournalEntry + (JournalSubmit + ("User \"" <> userDetailsIdent ud <> "\" recharged " <> + T.pack (show (fromIntegral amount / 100 :: Double))) + amount + ) + conn + void $ addToUserBalance uid amount conn + else + throwError $ err406 + { errBody = "Amounts less or equal zero are not acceptable" + } + else + throwError $ err403 + { errBody = "Wrong Authentication present" + } +userRecharge Nothing _ = + throwError $ err403 + { errBody = "No Authentication present" + }