This commit is contained in:
nek0 2020-08-24 09:43:22 +02:00
parent fade6374fa
commit 69aa5b4e09
8 changed files with 27 additions and 30 deletions

View File

@ -88,7 +88,7 @@ main = do
store <- newTVarIO S.empty store <- newTVarIO S.empty
-- tracker <- newTVarIO M.empty -- tracker <- newTVarIO M.empty
migrationsExist <- existsTable conn "schema_migrations" migrationsExist <- existsTable conn "schema_migrations"
when (not migrationsExist) $ do unless migrationsExist $ do
withTransaction conn $ withTransaction conn $
void $ do void $ do
runMigration $ runMigration $
@ -110,7 +110,7 @@ main = do
case ok of case ok of
MigrationError err -> do MigrationError err -> do
putStrLn ("Migration validation error: " ++ err) putStrLn ("Migration validation error: " ++ err)
putStrLn ("Running Migrations!") putStrLn "Running Migrations!"
void $ withTransaction conn $ runMigration $ void $ withTransaction conn $ runMigration $
MigrationContext (MigrationDirectory migLoc) True conn MigrationContext (MigrationDirectory migLoc) True conn
MigrationSuccess -> return () MigrationSuccess -> return ()
@ -119,11 +119,11 @@ main = do
case ok2 of case ok2 of
MigrationError err -> do MigrationError err -> do
putStrLn ("Migration validation error: " ++ err) putStrLn ("Migration validation error: " ++ err)
putStrLn ("MIgration failure! exiting...") putStrLn "MIgration failure! exiting..."
exitWith (ExitFailure 3) exitWith (ExitFailure 3)
MigrationSuccess -> do MigrationSuccess -> do
putStrLn ("Migration validation success!") putStrLn "Migration validation success!"
putStrLn ("starting up...") putStrLn "starting up..."
forkCleanProcess conn store forkCleanProcess conn store
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
let settings = setPort (fromIntegral lport) $ let settings = setPort (fromIntegral lport) $

View File

@ -22,7 +22,7 @@ journalShow (Just (uid, method)) mlimit moffset = do
maySeeJournal <- anyM maySeeJournal <- anyM
(checkCapability uid) (checkCapability uid)
[roleCanViewJournal, roleCanManageJournal] [roleCanViewJournal, roleCanManageJournal]
if (method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal) if method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal
then do then do
conn <- asks rsConnection conn <- asks rsConnection
selectJournalEntries mlimit moffset conn selectJournalEntries mlimit moffset conn
@ -41,7 +41,7 @@ journalCheck
-> MateHandler () -> MateHandler ()
journalCheck (Just (uid, method)) check = do journalCheck (Just (uid, method)) check = do
mayCheckJournal <- checkCapability uid roleCanManageJournal mayCheckJournal <- checkCapability uid roleCanManageJournal
if (method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal) if method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal
then do then do
conn <- asks rsConnection conn <- asks rsConnection
void $ insertNewCashCheck check conn void $ insertNewCashCheck check conn

View File

@ -23,7 +23,7 @@ productNew
-> MateHandler Int -> MateHandler Int
productNew (Just (uid, auth)) bevsub = do productNew (Just (uid, auth)) bevsub = do
mayAddProduct <- checkCapability uid roleCanManageProducts mayAddProduct <- checkCapability uid roleCanManageProducts
if (auth `elem` [PrimaryPass, ChallengeResponse] && mayAddProduct) if auth `elem` [PrimaryPass, ChallengeResponse] && mayAddProduct
then do then do
conn <- asks rsConnection conn <- asks rsConnection
bevid <- insertProduct bevsub conn bevid <- insertProduct bevsub conn
@ -53,13 +53,13 @@ productStockRefill (Just (uid, auth)) amorefs = do
mayRefill <- anyM mayRefill <- anyM
(checkCapability uid) (checkCapability uid)
[ roleCanRefillStock, roleCanManageProducts ] [ roleCanRefillStock, roleCanManageProducts ]
if (auth `elem` [PrimaryPass, ChallengeResponse] && mayRefill) if auth `elem` [PrimaryPass, ChallengeResponse] && mayRefill
then do then do
conn <- asks rsConnection conn <- asks rsConnection
prods <- mapM prods <- mapM
(\refill -> productSelectSingle (amountRefillProductId refill) conn) (\refill -> productSelectSingle (amountRefillProductId refill) conn)
amorefs amorefs
if all (not . null) prods if not (any null prods)
then then
if if
all all
@ -93,7 +93,7 @@ productStockUpdate
-> MateHandler () -> MateHandler ()
productStockUpdate (Just (uid, method)) amoups = do productStockUpdate (Just (uid, method)) amoups = do
mayUpdateStock <- checkCapability uid roleCanManageProducts mayUpdateStock <- checkCapability uid roleCanManageProducts
if (method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock) if method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock
then then
if all ((>= 0) . amountUpdateRealAmount) amoups if all ((>= 0) . amountUpdateRealAmount) amoups
then do then do

View File

@ -28,7 +28,7 @@ roleNew
roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9) = roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9) =
do do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then
insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 =<< asks rsConnection insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 =<< asks rsConnection
else else
@ -47,7 +47,7 @@ roleUpdate
-> MateHandler () -> MateHandler ()
roleUpdate (Just (uid, auth)) id_ roleSubmit = do roleUpdate (Just (uid, auth)) id_ roleSubmit = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then
void $ updateRole id_ roleSubmit =<< asks rsConnection void $ updateRole id_ roleSubmit =<< asks rsConnection
else else
@ -65,7 +65,7 @@ roleDelete
-> MateHandler () -> MateHandler ()
roleDelete (Just (uid, auth)) id_ = do roleDelete (Just (uid, auth)) id_ = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then
void $ deleteRole id_ =<< asks rsConnection void $ deleteRole id_ =<< asks rsConnection
else else
@ -88,7 +88,7 @@ roleAssociationSubmit
-> MateHandler () -> MateHandler ()
roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then
associateUserToRole auid arid =<< asks rsConnection associateUserToRole auid arid =<< asks rsConnection
else else
@ -106,7 +106,7 @@ roleAssociationDelete
-> MateHandler () -> MateHandler ()
roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then
void $ deleteAssociation auid arid =<< asks rsConnection void $ deleteAssociation auid arid =<< asks rsConnection
else else

View File

@ -113,7 +113,7 @@ getLatestAmountByProductId pid conn = do
, Bool , Bool
) )
] ]
head <$> return ( map return (head $ map
(\(_, _, amount, _, _) -> amount) (\(_, _, amount, _, _) -> amount)
amounts amounts
) )
@ -135,7 +135,7 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do
, Bool , Bool
) )
] ]
(amount *) . head <$> return (map return $ ((amount *) . head) (map
(\(_, _, _, price, _) -> price) (\(_, _, _, price, _) -> price)
amounts amounts
) )

View File

@ -3,7 +3,7 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
module Model.Journal where module Model.Journal where
import Data.Maybe (isJust, fromJust) import Data.Maybe
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.Time.Clock import Data.Time.Clock
@ -74,9 +74,7 @@ selectJournalEntries mlimit moffset conn = liftIO $ do
let lim = case mlimit of let lim = case mlimit of
Just l -> limit (l + 1) Just l -> limit (l + 1)
Nothing -> id Nothing -> id
off = case moffset of off = maybe id offset moffset
Just o -> offset o
Nothing -> id
entries <- runSelect conn entries <- runSelect conn
( proc () -> do ( proc () -> do
ret <- lim $ off $ orderBy (desc (\(id_, _, _, _, _) -> id_)) ret <- lim $ off $ orderBy (desc (\(id_, _, _, _, _) -> id_))

View File

@ -321,7 +321,7 @@ manualProductAmountRefill aups conn =
(\(AmountRefill pid amountSingles amountCrates) -> do (\(AmountRefill pid amountSingles amountCrates) -> do
oldamount <- getLatestAmountByProductId pid conn oldamount <- getLatestAmountByProductId pid conn
oldprice <- getLatestPriceByProductId pid conn oldprice <- getLatestPriceByProductId pid conn
perCrate <- (productAmountPerCrate . head) <$> perCrate <- productAmountPerCrate . head <$>
productSelectSingle pid conn productSelectSingle pid conn
head <$> liftIO (do head <$> liftIO (do
now <- getCurrentTime now <- getCurrentTime

View File

@ -1,6 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Model.Role where module Model.Role where
@ -202,8 +201,8 @@ selectRoleList
-> MateHandler [Role] -> MateHandler [Role]
selectRoleList ids conn = do selectRoleList ids conn = do
rawRoles <- liftIO $ runSelect conn ( rawRoles <- liftIO $ runSelect conn (
(keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _) -> keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _) ->
in_ (map C.constant ids) id_)) in_ (map C.constant ids) id_)
<<< queryTable roleTable <<< queryTable roleTable
) :: MateHandler ) :: MateHandler
[ [
@ -341,7 +340,7 @@ selectAllRoleAssociations conn = do
) )
] ]
return $ map return $ map
(\(uid, rid) -> RoleAssociation uid rid) (uncurry RoleAssociation)
rawRoleAssocs rawRoleAssocs
@ -359,7 +358,7 @@ selectUserAssociations uid conn = do
, Int , Int
) )
] ]
return $ map (\(auid, arid) -> RoleAssociation auid arid) rawAssocs return $ map (uncurry RoleAssociation) rawAssocs
associateUserToRole associateUserToRole
@ -390,7 +389,7 @@ deleteAssociation uid rid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = userToRoleTable { dTable = userToRoleTable
, dWhere = , dWhere =
(\(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid) \(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid
, dReturning = rCount , dReturning = rCount
} }
@ -430,6 +429,6 @@ deleteRole rid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = roleTable { dTable = roleTable
, dWhere = , dWhere =
(\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid) \(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid
, dReturning = rCount , dReturning = rCount
} }