add files

This commit is contained in:
nek0 2019-08-14 18:04:16 +02:00
parent aab443cc92
commit 520ab40070
3 changed files with 191 additions and 0 deletions

34
src/Control/Auth.hs Normal file
View File

@ -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"
}

62
src/Control/Product.hs Normal file
View File

@ -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

95
src/Control/User.hs Normal file
View File

@ -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"
}