linted and hunted down warnings

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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