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

reducing warnings to 0

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/API.hs
View file

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

8
src/Control/Auth.hs
View file

@ -3,18 +3,14 @@ module Control.Auth where
import Servant import Servant
import Control.Monad (void)
import Control.Monad.Reader (ask)
-- internal imports -- internal imports
import Types import Types
import Model import Model
authGet :: Int -> MateHandler AuthInfo authGet :: Int -> MateHandler AuthInfo
authGet id = authGet uid =
getUserAuthInfo id getUserAuthInfo uid
authSend :: AuthRequest -> MateHandler AuthResult authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest authSend = processAuthRequest

8
src/Control/Buy.hs
View file

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

16
src/Control/User.hs
View file

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

22
src/Model/Auth.hs
View file

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

12
src/Model/Journal.hs
View file

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

35
src/Model/Product.hs
View file

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

30
src/Model/User.hs
View file

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

4
src/Types/Auth.hs
View file

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

2
src/Types/Purchase.hs
View file

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

2
src/Types/Refine.hs
View file

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

7
src/Types/User.hs
View file

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