nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

linted and hunted down warnings

Browse source
This commit is contained in:
nek0 2019-10-14 22:50:42 +02:00
parent 892d3f0610
commit 4000e42110
17 changed files with 179 additions and 154 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
app/Main.hs
View file

@ -107,9 +107,8 @@ authHandler conn = mkAuthHandler handler
handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do
let headers = requestHeaders req
res <- case lookup "Authentication" headers of
Just hh -> do
case lookup "Authentication" headers of
Just hh ->
validateToken hh conn
_ ->
return Nothing
return res

82
src/API.hs
View file

@ -1,10 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -68,34 +65,65 @@ type MateAPI =
:<|> "avatar" :> "list" :> Get '[JSON] [Avatar]
( authGetLink :<|>
authSendLink :<|>
authLogoutLink :<|>
authGetLink :: Link
authSendLink :: Link
authLogoutLink :: Link
authManageListLink :<|>
authManageNewAuthLink :<|>
authManageDeleteAuthLink :<|>
authManageListLink :: Link
authManageNewAuthLink :: Link
authManageDeleteAuthLink :: Link
userNewLink :<|>
userGetLink :<|>
userUpdateLink :<|>
userListLink :<|>
userRechargeLink :<|>
userTransferLink :<|>
userNewLink :: Link
userGetLink :: Link
userUpdateLink :: Link
userListLink :: Maybe UserRefine -> Link
userRechargeLink :: Link
userTransferLink :: Link
productNewLink :<|>
productOverviewLink :<|>
productStockRefillLink :<|>
productStockUpdateLink :<|>
productListLink :<|>
productShortListLink :<|>
productNewLink :: Link
productOverviewLink :: Int -> Link
productStockRefillLink :: Link
productStockUpdateLink :: Link
productListLink :: Maybe ProductRefine -> Link
productShortListLink :: Maybe ProductRefine -> Link
buyLink :<|>
buyLink :: Link
journalShowLink :<|>
journalShowLink :: Maybe Int -> Maybe Int -> Link
avatarGetLink :<|>
avaterInsertLink :<|>
avatarUpdateLink :<|>
avatarListLink
avatarGetLink :: Int -> Link
avaterInsertLink :: Link
avatarUpdateLink :: Int -> Link
avatarListLink :: Link
( (authGetLink :: Link) :<|>
(authSendLink :: Link) :<|>
(authLogoutLink :: Link) :<|>
(authManageListLink :: Link) :<|>
(authManageNewAuthLink :: Link) :<|>
(authManageDeleteAuthLink :: Link) :<|>
(userNewLink :: Link) :<|>
(userGetLink :: Link) :<|>
(userUpdateLink :: Link) :<|>
(userListLink :: Maybe UserRefine -> Link) :<|>
(userRechargeLink :: Link) :<|>
(userTransferLink :: Link) :<|>
(productNewLink :: Link) :<|>
(productOverviewLink :: Int -> Link) :<|>
(productStockRefillLink :: Link) :<|>
(productStockUpdateLink :: Link) :<|>
(productListLink :: Maybe ProductRefine -> Link) :<|>
(productShortListLink :: Maybe ProductRefine -> Link) :<|>
(buyLink :: Link) :<|>
(journalShowLink :: Maybe Int -> Maybe Int -> Link) :<|>
(avatarGetLink :: Int -> Link) :<|>
(avaterInsertLink :: Link) :<|>
(avatarUpdateLink :: Int -> Link) :<|>
(avatarListLink :: Link)
) = allLinks (Proxy :: Proxy MateAPI)

32
src/Control/Auth.hs
View file

@ -5,7 +5,7 @@ import Servant
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks, ask)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO)
@ -18,23 +18,23 @@ import Model
authGet
:: TicketRequest
-> MateHandler AuthInfo
authGet (TicketRequest uid method) = do
getUserAuthInfo uid method =<< (rsConnection <$> ask)
authGet (TicketRequest uid method) =
getUserAuthInfo uid method =<< (asks rsConnection)
authSend
:: AuthRequest
-> MateHandler AuthResult
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
(liftIO . readTVarIO =<< rsTicketStore <$> ask) <*>
(rsConnection <$> ask)
(asks rsConnection)
)
authLogout
:: Maybe (Int, AuthMethod)
-> MateHandler ()
authLogout (Just (muid, method)) = do
processLogout muid =<< (rsConnection <$> ask)
authLogout Nothing = do
authLogout (Just (muid, _)) =
processLogout muid =<< (asks rsConnection)
authLogout Nothing =
throwError $ err401
{ errBody = "Unauthorized access"
}
@ -43,9 +43,9 @@ authManageList
:: Maybe (Int, AuthMethod)
-> MateHandler [AuthOverview]
authManageList (Just (uid, method)) =
if any (== method) [PrimaryPass, ChallengeResponse]
if elem method [PrimaryPass, ChallengeResponse]
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
selectAuthOverviews uid conn
else
throwError $ err401
@ -60,10 +60,10 @@ authManageNewAuth
:: Maybe (Int, AuthMethod)
-> AuthSubmit
-> MateHandler Int
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = do
if any (== method) [PrimaryPass, ChallengeResponse]
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
if elem method [PrimaryPass, ChallengeResponse]
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
putUserAuthInfo uid asmethod ascomment aspayload conn
else
throwError $ err401
@ -78,10 +78,10 @@ authManageDeleteAuth
:: Maybe (Int, AuthMethod)
-> Int
-> MateHandler ()
authManageDeleteAuth (Just (uid, method)) adid = do
if any (== method) [PrimaryPass, ChallengeResponse]
authManageDeleteAuth (Just (uid, method)) adid =
if elem method [PrimaryPass, ChallengeResponse]
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
ads <- selectAuthOverviews uid conn
let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
case authOverviewMethod currentad of
@ -107,7 +107,7 @@ authManageDeleteAuth (Just (uid, method)) adid = do
throwError $ err406
{ errBody = "You need at least one primary password or challenge response authentication"
}
authManageDeleteAuth Nothing _ = do
authManageDeleteAuth Nothing _ =
throwError $ err401
{ errBody = "Unauthorized access"
}

12
src/Control/Avatar.hs
View file

@ -3,7 +3,7 @@ module Control.Avatar where
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks)
import Control.Monad.Trans (liftIO)
@ -26,7 +26,7 @@ avatarGet
:: Int
-> MateHandler Application
avatarGet aid = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
as <- liftIO $ avatarSelectById aid conn
if null as
then
@ -47,7 +47,7 @@ avatarInsert
-> AvatarData
-> MateHandler Int
avatarInsert (Just _) ad = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
insertAvatar ad conn
avatarInsert Nothing _ =
throwError $ err401
@ -60,9 +60,9 @@ avatarUpdate
-> AvatarData
-> MateHandler ()
avatarUpdate (Just _) aid ad = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
void $ updateAvatar aid ad conn
avatarUpdate Nothing _ _ = do
avatarUpdate Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}
@ -70,5 +70,5 @@ avatarUpdate Nothing _ _ = do
avatarList
:: MateHandler [Avatar]
avatarList = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
liftIO $ avatarSelect conn

16
src/Control/Buy.hs
View file

@ -3,7 +3,7 @@ module Control.Buy where
import Control.Monad (void, foldM)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks)
-- internal imports
@ -15,13 +15,13 @@ buy
-> [PurchaseDetail]
-> MateHandler PurchaseResult
buy (Just (auid, _)) pds = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
(missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
, pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
)
Nothing -> return
( ms
@ -30,7 +30,7 @@ buy (Just (auid, _)) pds = do
)
([], [])
pds
void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real
mapM_ (`postBuyProductAmountUpdate` conn) real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
@ -46,13 +46,13 @@ buy (Just (auid, _)) pds = do
)
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
(missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
, pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
)
Nothing -> return
( ms
@ -61,8 +61,8 @@ buy Nothing pds = do
)
([], [])
pds
void $ mapM_
(\pd -> postBuyProductAmountUpdate pd conn)
mapM_
(`postBuyProductAmountUpdate` conn)
real
price <- foldM
(\total pd ->

4
src/Control/Journal.hs
View file

@ -3,7 +3,7 @@ module Control.Journal where
import Servant
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks)
-- internal imports
@ -16,7 +16,7 @@ journalShow
-> Maybe Int
-> MateHandler [JournalEntry]
journalShow (Just _) mlimit moffset = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
selectJournalEntries mlimit moffset conn
journalShow Nothing _ _ =
throwError $ err401

20
src/Control/Product.hs
View file

@ -5,7 +5,7 @@ import Servant
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks)
import Data.Maybe (fromMaybe)
@ -19,28 +19,28 @@ productNew
-> ProductSubmit
-> MateHandler Int
productNew (Just _) bevsub = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid bevsub conn
return bevid
productNew Nothing _ =
throwError $ err401
throwError err401
productOverview
:: Int
-> MateHandler ProductOverview
productOverview pid = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
productOverviewSelectSingle pid conn
productStockRefill
:: Maybe (Int, AuthMethod)
-> [AmountRefill]
-> MateHandler ()
productStockRefill (Just _) amorefs = do
productStockRefill (Just _) amorefs =
if all ((>= 0) . amountRefillAmount) amorefs
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
void $ manualProductAmountRefill amorefs conn
else
throwError $ err400
@ -55,10 +55,10 @@ productStockUpdate
:: Maybe (Int, AuthMethod)
-> [AmountUpdate]
-> MateHandler ()
productStockUpdate (Just _) amoups = do
productStockUpdate (Just _) amoups =
if all ((>= 0) . amountUpdateRealAmount) amoups
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
void $ manualProductAmountUpdate amoups conn
else
throwError $ err400
@ -73,12 +73,12 @@ productList
:: Maybe ProductRefine
-> MateHandler [ProductOverview]
productList mrefine = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
productOverviewSelect (fromMaybe AvailableProducts mrefine) conn
productShortList
:: Maybe ProductRefine
-> MateHandler [ProductShortOverview]
productShortList mrefine = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn

22
src/Control/User.hs
View file

@ -5,7 +5,7 @@ import Servant
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
@ -24,8 +24,8 @@ userNew
:: UserSubmit
-> MateHandler Int
userNew (UserSubmit ident email passhash) = do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
now <- liftIO getCurrentTime
conn <- asks rsConnection
uid <- insertUser ident email (utctDay now) conn
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
return uid
@ -38,7 +38,7 @@ userGet Nothing =
{ errBody = "No Authentication present."
}
userGet (Just (uid, _)) = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
userDetailsSelect uid conn
userUpdate
@ -50,10 +50,10 @@ userUpdate Nothing _ =
{ errBody = "No Authentication present."
}
userUpdate (Just (aid, method)) uds =
if any (== method) [PrimaryPass, ChallengeResponse]
if elem method [PrimaryPass, ChallengeResponse]
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
now <- liftIO getCurrentTime
conn <- asks rsConnection
void $ updateUserDetails aid uds (utctDay now) conn
else
throwError $ err401
@ -64,7 +64,7 @@ userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
userList ref = do
conn <- rsConnection <$> ask
conn <- asks rsConnection
userSelect (fromMaybe ActiveUsers ref) conn
userRecharge
@ -74,7 +74,7 @@ userRecharge
userRecharge (Just (auid, _)) (UserRecharge amount) =
if amount >= 0
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
ud <- userDetailsSelect auid conn
void $ insertNewJournalEntry
(JournalSubmit
@ -102,9 +102,9 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) =
then
if auid /= target
then
if any (== method) [PrimaryPass, ChallengeResponse]
if elem method [PrimaryPass, ChallengeResponse]
then do
conn <- rsConnection <$> ask
conn <- asks rsConnection
user <- userDetailsSelect auid conn
if amount < userDetailsBalance user
then do

12
src/Model/Amount.hs
View file

@ -135,7 +135,7 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do
, Bool
)
]
(amount *) <$> head <$> return (map
(amount *) . head <$> return (map
(\(_, _, _, price, _) -> price)
amounts
)
@ -145,7 +145,7 @@ checkProductAvailability
-> PGS.Connection
-> MateHandler (Maybe Int) -- | Returns maybe missing amount
checkProductAvailability (PurchaseDetail pid amount) conn = do
realamount <- (\(_, _, ramount, _, _) -> ramount) <$> head <$>
realamount <- (\(_, _, ramount, _, _) -> ramount) . head <$>
(liftIO $ runSelect conn $ limit 1 $
orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
@ -172,7 +172,7 @@ manualProductAmountUpdate aups conn =
mapM
(\(AmountUpdate pid amount) -> do
oldprice <- getLatestPriceByProductId pid conn
head <$> (liftIO $ do
head <$> liftIO (do
now <- getCurrentTime
runInsert_ conn $ Insert
{ iTable = amountTable
@ -202,7 +202,7 @@ manualProductAmountRefill aups conn =
(\(AmountRefill pid amount) -> do
oldamount <- getLatestAmountByProductId pid conn
oldprice <- getLatestPriceByProductId pid conn
head <$> (liftIO $ do
head <$> liftIO (do
now <- getCurrentTime
runInsert_ conn $ Insert
{ iTable = amountTable
@ -228,8 +228,8 @@ postBuyProductAmountUpdate
-> PGS.Connection
-> MateHandler Int
postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
now <- liftIO $ getCurrentTime
(amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) <$> head <$> (
now <- liftIO getCurrentTime
(amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) . head <$> (
liftIO $ runSelect conn $ limit 1 $
orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<

47
src/Model/Auth.hs
View file

@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -29,10 +28,9 @@ import qualified Data.Set as S
import Data.Time.Clock
import Data.ByteString as B (ByteString, drop)
import Data.ByteString as B (ByteString)
import Data.ByteString.Random
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base16 as B16
import Opaleye hiding (null)
import qualified Opaleye.Constant as C
@ -114,7 +112,7 @@ delayTime = 1 * 10 ^ (6 :: Int)
generateRandomText :: IO T.Text
generateRandomText = decodeUtf8 <$> B64.encode <$> random 23
generateRandomText = decodeUtf8 . B64.encode <$> random 23
selectAuthOverviews
@ -123,7 +121,7 @@ selectAuthOverviews
-> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do
authData <- liftIO $ runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, adpayload) <-
(adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< ()
restrict -< aduid .== C.constant uid
returnA -< (adid, adcomment, admethod)
@ -147,8 +145,8 @@ getUserAuthInfo
-> MateHandler AuthInfo
getUserAuthInfo uid method conn = do
authdata <- map (\(aid, auid, amethod, acomment, apayload) ->
(aid, auid, amethod, acomment, (decodeUtf8 $ B64.encode apayload))) <$>
(liftIO $ do
(aid, auid, amethod, acomment, decodeUtf8 $ B64.encode apayload)) <$>
liftIO (do
void $ threadDelay delayTime
runSelect conn (proc () -> do
(aid, auid, amethod, acomment, apayload) <-
@ -207,7 +205,7 @@ deleteAuthDataById
-> MateHandler Int64
deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = authDataTable
, dWhere = (\(aid, _, _, _, _) -> aid .== C.constant adid)
, dWhere = \(aid, _, _, _, _) -> aid .== C.constant adid
, dReturning = rCount
}
@ -229,7 +227,7 @@ validateToken header conn = do
]
case tokens of
[(_, uid, stamp, method)] -> do
now <- liftIO $ getCurrentTime
now <- liftIO getCurrentTime
if diffUTCTime stamp now > 0
then return $ Just (uid, toEnum method)
else do
@ -250,7 +248,7 @@ generateToken
-> AuthResponse
-> PGS.Connection
-> MateHandler AuthResult
generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
authData <- liftIO $ runSelect conn (
keepWhen (\(_, auid, amethod, _, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
@ -263,8 +261,11 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
, ByteString
)
]
let userPayloads = map (\(_, _, _, _, payload) ->
(decodeUtf8 payload)) authData
let userPayloads = map
(\(_, _, _, _, payload) ->
decodeUtf8 payload
)
authData
authResult = case method of
PrimaryPass -> validatePass response userPayloads
SecondaryPass -> validatePass response userPayloads
@ -282,9 +283,9 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
else
return Denied
where
validatePass provided presents =
any (\present -> provided == present) presents
validateChallengeResponse provided presents =
validatePass provided =
any (provided ==)
validateChallengeResponse _ _ =
error "Validation of challenge response authentication not yet implemented"
@ -315,7 +316,7 @@ deleteToken
deleteToken tstr conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = (\(rtstr, _, _, _) -> rtstr .== C.constant tstr)
, dWhere = \(rtstr, _, _, _) -> rtstr .== C.constant tstr
, dReturning = rCount
}
@ -326,7 +327,7 @@ deleteTokenByUserId
-> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = (\(_, rid, _, _) -> rid .== C.constant uid)
, dWhere = \(_, rid, _, _) -> rid .== C.constant uid
, dReturning = rCount
}
@ -334,18 +335,18 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do
store <- rsTicketStore <$> ask
rand1 <- liftIO $ generateRandomText
rand1 <- liftIO generateRandomText
rand2 <- liftIO $ case method of
ChallengeResponse -> Just <$> generateRandomText
_ -> return Nothing
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
later <- liftIO (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket
{ ticketId = AuthTicket rand1
, ticketUser = ident
, ticketExpiry = later
, ticketMethod = (method, rand2)
}
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
liftIO $ atomically $ modifyTVar store (S.insert ticket)
return (rand2, AuthTicket rand1)
@ -359,7 +360,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
case S.toList mticket of
[ticket] -> do
-- liftIO $ putStrLn "there is a ticket..."
now <- liftIO $ getCurrentTime
now <- liftIO getCurrentTime
liftIO $ threadDelay delayTime
if now > ticketExpiry ticket
then
@ -374,7 +375,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
#else
return Denied
#endif
else do
else
-- liftIO $ putStrLn "...and it is valid"
generateToken ticket hash conn
_ -> do
@ -395,5 +396,5 @@ processLogout
:: Int
-> PGS.Connection
-> MateHandler ()
processLogout uid conn = do
processLogout uid conn =
void $ deleteTokenByUserId uid conn

2
src/Model/Avatar.hs
View file

@ -137,6 +137,6 @@ updateAvatar aid (AvatarData name dat) conn = liftIO $ do
, C.constant (encodeUtf8 dat)
)
)
, uWhere = (\(did, _, _, _) -> did .== C.constant aid)
, uWhere = \(did, _, _, _) -> did .== C.constant aid
, uReturning = rCount
}

3
src/Model/Journal.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Arrows #-}
module Model.Journal where
@ -130,7 +131,7 @@ insertNewJournalEntry
-> PGS.Connection
-> MateHandler Int
insertNewJournalEntry (JournalSubmit descr amount) conn = do
lastTotal <- (\x -> case x of
lastTotal <- (\case
Just j -> journalEntryTotalAmount j
Nothing -> 0
) <$> selectLatestJournalEntry conn

60
src/Model/Product.hs
View file

@ -105,7 +105,7 @@ productOverviewSelect refine conn = do
prods <- liftIO $ runSelect conn
( proc () -> do
(pid, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
(a1, a2, a3, a4, a5) <-
(a1, _, a3, _, _) <-
limit 1 (
orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable))
-< ()
@ -144,22 +144,22 @@ productOverviewSelect refine conn = do
)
]
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
ii5 <- return $ (\(_, x) -> x) $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
let ii5 = snd $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
)
(0, 0)
(Prelude.reverse amounts)
ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
)
@ -205,22 +205,22 @@ productOverviewSelectSingle pid conn = do
)
]
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
ii5 <- return $ (\(_, x) -> x) $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
let ii5 = snd $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
)
(0, 0)
(Prelude.reverse amounts)
ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
)
@ -235,7 +235,7 @@ productShortOverviewSelect refine conn = do
prods <- liftIO $ runSelect conn
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
(a1, a2, a3, a4, a5) <-
(a1, _, a3, _, _) <-
limit 1 (
orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable))
-< ()

10
src/Model/User.hs
View file

@ -70,7 +70,7 @@ userSelect
-> PGS.Connection
-> MateHandler [UserSummary]
userSelect ref conn = do
today <- utctDay <$> (liftIO $ getCurrentTime)
today <- utctDay <$> (liftIO getCurrentTime)
users <- liftIO $ runSelect conn (case ref of
AllUsers -> selectTable userTable
ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
@ -138,9 +138,7 @@ userBalanceSelect conn uid = do
)
]
head <$> mapM
(\(_, _, i3, _, _, _) -> return $
i3
)
(\(_, _, i3, _, _, _) -> return i3)
users
@ -183,7 +181,7 @@ updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
, C.constant (userDetailsSubmitAvatar uds)
)
)
, uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid)
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
, uReturning = rCount
}
@ -203,6 +201,6 @@ addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
, i6
)
)
, uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid)
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
, uReturning = rCount
}

1
src/Types/Auth.hs
View file

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Types.Auth where

2
src/Types/Journal.hs
View file

@ -38,7 +38,7 @@ instance ToJSON JournalSubmit where
instance FromJSON JournalSubmit
data JournalCashCheck = JournalCashCheck
newtype JournalCashCheck = JournalCashCheck
{ journalCashCheckTotalAmount :: Int
}
deriving (Generic, Show)

3
src/Types/User.hs
View file

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Types.User where
import GHC.Generics
@ -85,7 +84,7 @@ instance ToJSON UserDetailsSubmit where
instance FromJSON UserDetailsSubmit
data UserRecharge = UserRecharge
newtype UserRecharge = UserRecharge
{ userRechargeAmount :: Int
}
deriving (Generic, Show)