reducing warnings to 0

This commit is contained in:
nek0 2019-09-07 02:48:16 +02:00
parent 3575cd265d
commit e53a67ae02
12 changed files with 47 additions and 104 deletions

View file

@ -10,15 +10,10 @@
module API where
import Data.Text
import Data.Time (UTCTime)
import Servant.API
-- internal imports
import Model as M
import Types
type UserAPI =

View file

@ -3,18 +3,14 @@ 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
authGet uid =
getUserAuthInfo uid
authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest

View file

@ -1,8 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Control.Buy where
import Servant
import Control.Monad (void, foldM)
import Control.Monad.Reader (ask)
@ -18,7 +16,7 @@ buy
-> MateHandler PurchaseResult
buy (Just auid) pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
(missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
@ -39,7 +37,7 @@ buy (Just auid) pds = do
)
0
real
addToUserBalance auid (-price) conn
void $ addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
( if newBalance < 0
@ -49,7 +47,7 @@ buy (Just auid) pds = do
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
(missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return

View file

@ -32,13 +32,11 @@ userGet Nothing _ =
throwError $ err403
{ errBody = "No Authentication present."
}
userGet (Just aid) id =
if aid == id
userGet (Just aid) uid =
if aid == uid
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
-- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
userDetailsSelect id conn
userDetailsSelect uid conn
else
throwError $ err403
{ errBody = "Wrong Authentication present."
@ -49,19 +47,19 @@ userUpdate Nothing _ _ =
throwError $ err403
{ errBody = "No Authentication present."
}
userUpdate (Just aid) id uds =
if aid == id
userUpdate (Just aid) uid uds =
if aid == uid
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
void $ updateUserDetails id uds (utctDay now) conn
void $ updateUserDetails uid uds (utctDay now) conn
else
throwError $ err403
{ errBody = "Wrong Authentication present."
}
userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
userList muid ref = do
userList _ ref = do
conn <- rsConnection <$> ask
userSelect ref conn

View file

@ -5,8 +5,6 @@ module Model.Auth where
import Servant
import GHC.Generics
import Control.Arrow ((<<<))
import Control.Monad (void)
@ -15,7 +13,7 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
@ -74,6 +72,8 @@ tokenTable = table "token" (
)
)
delayTime :: Int
delayTime = 1 * 10 ^ (6 :: Int)
getUserAuthInfo
:: Int
@ -81,7 +81,7 @@ getUserAuthInfo
getUserAuthInfo ident = do
conn <- rsConnection <$> ask
users <- liftIO $ do
void $ threadDelay $ 1 * 10 ^ 6
void $ threadDelay delayTime
runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant ident) <<< queryTable userTable
@ -102,7 +102,7 @@ getUserAuthInfo ident = do
{ errBody = "No such user"
}
else
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) ->
head <$> mapM (\(_, _, _, _, _, _, i7, _, i9) ->
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
)
users
@ -129,12 +129,12 @@ validateToken conn header = do
then return $ Just uid
else do
void $ deleteToken header conn
liftIO $ threadDelay $ 1 * 10 ^ 6
liftIO $ threadDelay delayTime
throwError $ err401
{ errBody = "Your token expired!"
}
_ -> do
liftIO $ threadDelay $ 1 * 10 ^ 6
liftIO $ threadDelay delayTime
throwError $ err401
{ errBody = "No valid token found!"
}
@ -144,7 +144,7 @@ generateToken
:: Ticket
-> AuthHash
-> MateHandler AuthResult
generateToken (Ticket _ ident exp) (AuthHash hash) = do
generateToken (Ticket _ ident _) (AuthHash hash) = do
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
@ -161,7 +161,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
, Maybe Int
)
]
let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8) users
let userHash = head $ map (\(_, _, _, _, _, _, _, i8, _) -> i8) users
if userHash == Nothing || userHash == Just hash
then do
token <- liftIO $ Token
@ -239,7 +239,7 @@ processAuthRequest (AuthRequest aticket hash) = do
case S.toList mticket of
[ticket] -> do
now <- liftIO $ getCurrentTime
liftIO $ threadDelay $ 1 * 10 ^ 6
liftIO $ threadDelay delayTime
if now > ticketExpiry ticket
then
#if defined(DEVELOP)
@ -252,7 +252,7 @@ processAuthRequest (AuthRequest aticket hash) = do
else
generateToken ticket hash
_ -> do
liftIO $ threadDelay $ 1 * 10 ^ 6
liftIO $ threadDelay delayTime
#if defined(DEVELOP)
do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime

View file

@ -86,8 +86,8 @@ selectJournalEntries mlimit moffset conn = liftIO $ do
)
]
return $ fst $ foldr
(\(id_, ts, desc, tot, check) (fin, last)->
(JournalEntry id_ desc ts (tot - last) tot check : fin, tot)
(\(id_, ts, descr, tot, check) (fin, before)->
(JournalEntry id_ descr ts (tot - before) tot check : fin, tot)
)
( []
, if isJust mlimit && not (null entries)
@ -119,8 +119,8 @@ selectLatestJournalEntry conn = liftIO $ do
if not (null lastTwoEntries)
then do
let diff = foldl (\acc (_, _, _, tot, _) -> tot - acc) 0 lastTwoEntries
(id, ts, desc, total, check) = head lastTwoEntries
return $ Just $ JournalEntry id desc ts diff total check
(jid, ts, descr, total, check) = head lastTwoEntries
return $ Just $ JournalEntry jid descr ts diff total check
else
return Nothing
@ -129,7 +129,7 @@ insertNewJournalEntry
:: JournalSubmit
-> PGS.Connection
-> MateHandler Int
insertNewJournalEntry (JournalSubmit desc amount) conn = do
insertNewJournalEntry (JournalSubmit descr amount) conn = do
lastTotal <- (\x -> case x of
Just j -> journalEntryTotalAmount j
Nothing -> 0
@ -142,7 +142,7 @@ insertNewJournalEntry (JournalSubmit desc amount) conn = do
[
( C.constant (Nothing :: Maybe Int)
, C.constant now
, C.constant desc
, C.constant descr
, C.constant (lastTotal + amount)
, C.constant False
)

View file

@ -1,31 +1,18 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Model.Product where
import Servant.Server
import Data.Text as T hiding (head, foldl)
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Profunctor.Product (p9)
import Data.Aeson
import Data.Aeson.Types
import Data.Int (Int64)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class (throwError)
import Control.Arrow ((<<<), returnA)
import qualified Database.PostgreSQL.Simple as PGS
import GHC.Generics
import Opaleye as O hiding (max)
import Opaleye.Constant as C
@ -251,7 +238,7 @@ productShortOverviewSelect conn = do
)
]
mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
(\(i1, i2, i3, i4, _, _, _, _, _) -> do
amounts <- liftIO $ runSelect conn
( proc () -> do
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
@ -267,22 +254,6 @@ productShortOverviewSelect conn = do
)
]
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
ii5 <- return $ (\(_, x) -> x) $
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 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductShortOverview
i1 i2 ii3 ii4 i3 i4
)
@ -293,7 +264,7 @@ insertProduct
:: ProductSubmit
-> PGS.Connection
-> MateHandler Int
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn =
insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = productTable
, iRows =
@ -303,7 +274,7 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn =
, C.constant ml
, C.constant ava
, C.constant sup
, C.constant max
, C.constant maxi
, C.constant apc
, C.constant ppc
, C.constant artnr

View file

@ -1,6 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Model.User where
import Data.Text as T hiding (head, foldl)
@ -9,16 +7,12 @@ import Data.Time.Clock
import Data.Profunctor.Product (p9)
import Data.Maybe (fromJust, isJust, fromMaybe)
import Data.ByteString hiding (head, foldl)
import Data.Int (Int64)
import qualified Database.PostgreSQL.Simple as PGS
import GHC.Generics
import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
@ -119,11 +113,10 @@ userDetailsSelect
:: Int
-> PGS.Connection
-> MateHandler UserDetails
userDetailsSelect id conn = do
today <- utctDay <$> (liftIO $ getCurrentTime)
userDetailsSelect uid conn = do
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id
keepWhen (\(uuid, _, _, _, _, _, _, _, _) ->
uuid .== C.constant uid
) <<< queryTable userTable
) :: MateHandler
[ ( Int
@ -138,8 +131,8 @@ userDetailsSelect id conn = do
)
]
head <$> mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
UserDetails i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9)
(\(i1, i2, i3, _, i5, i6, i7, _, i9) -> return $
UserDetails i1 i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9)
)
users
@ -148,11 +141,10 @@ userBalanceSelect
:: PGS.Connection
-> Int
-> MateHandler Int
userBalanceSelect conn id = do
today <- utctDay <$> (liftIO $ getCurrentTime)
userBalanceSelect conn uid = do
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id
keepWhen (\(uuid, _, _, _, _, _, _, _, _) ->
uuid .== C.constant uid
) <<< queryTable userTable
) :: MateHandler
[ ( Int
@ -167,7 +159,7 @@ userBalanceSelect conn id = do
)
]
head <$> mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
(\(_, _, i3, _, _, _, _, _, _) -> return $
i3
)
users
@ -194,7 +186,7 @@ insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
, C.constant (Nothing :: Maybe Int)
)
]
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
, iReturning = rReturning (\(uid, _, _, _, _, _, _, _, _) -> uid)
, iOnConflict = Nothing
}
@ -206,7 +198,7 @@ updateUserDetails
-> MateHandler Int64
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, _, _) ->
( id_
, C.constant (userDetailsSubmitIdent uds)
, i3

View file

@ -16,10 +16,6 @@ import Data.Time.Clock (UTCTime)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.IORef
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM.TVar (TVar)
-- internal imports

View file

@ -2,8 +2,6 @@
module Types.Purchase where
import Data.Text
import Data.Aeson
import GHC.Generics

View file

@ -3,8 +3,6 @@
module Types.Refine where
import Data.Text
import GHC.Generics
import Web.HttpApiData

View file

@ -29,9 +29,9 @@ data User
deriving (Generic, Show)
instance ToJSON User where
toEncoding (User id ident balance ts email avatar _ _ _) =
toEncoding (User uid ident _ _ _ avatar _ _ _) =
pairs
( "userId" .= id
( "userId" .= uid
<> "userIdent" .= ident
<> "userAvatar" .= avatar
)
@ -53,7 +53,8 @@ instance FromJSON UserSubmit
data UserDetails = UserDetails
{ userDetailsIdent :: T.Text
{ userDetailsId :: Int
, userDetailsIdent :: T.Text
, userDetailsBalance :: Int
, userDetailsEmail :: Maybe T.Text
, userDetailsAvatar :: Maybe Int