fix compilation errors

This commit is contained in:
nek0 2021-06-16 18:09:08 +02:00
parent 28709dd0cf
commit 2e958c0927
5 changed files with 27 additions and 22 deletions

View file

@ -175,5 +175,6 @@ test-suite mateamt-test
build-tool-depends:
hspec-discover:hspec-discover == 2.*
other-modules:
Spec
TestUtil
AppMainSpec

View file

@ -38,12 +38,12 @@ productNew Nothing _ =
{ errBody = "No Authentication present."
}
-- productOverview
-- :: Int
-- -> MateHandler ProductOverview
-- productOverview pid = do
-- conn <- asks rsConnection
-- productOverviewSelectSingle pid conn
productOverview
:: Int
-> MateHandler ProductOverview
productOverview pid = do
conn <- asks rsConnection
productOverviewSelectSingle pid conn
productStockRefill
:: Maybe (Int, AuthMethod)

View file

@ -13,6 +13,8 @@ import Data.Time (getCurrentTime, utctDay)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Text as T
-- internal imports
@ -150,19 +152,21 @@ userNotify
-> MateHandler ()
userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
conn <- asks rsConnection
authData <- selectAuthOverviewById auid conn
user <- userDetailsSelect (authDataUser authData) conn
authOV <- selectAuthOverviewById auid conn
userDetails <- userDetailsSelect (authOverviewUser authOV) conn
digestedDetails <- mapM
(\pd -> do
overview <- (productOverviewSelectSingle (purchaseDetailProduct pd) conn
return (purchaseDetailAmout pd, productOverviewIdent overview)
overview <- productOverviewSelectSingle (purchaseDetailProduct pd) conn
return (purchaseDetailAmount pd, productOverviewIdent overview)
)
boughtItems
let messageText = mconcat $ map (<> "\n") $
[ "Hello " <> userIdent user <> ","
[ "Hello " <> userDetailsIdent userDetails <> ","
, ""
, "Your " <> authDataMethod authData <> " with the comment \"" <>
authDataComment authData <> "\" Just made following purchase:"<>
, "Your " <> ((fromString $ show $ authOverviewMethod authOV) <>
(" with the comment \"" <>
((authOverviewComment authOV) <>
"\" Just made following purchase:")))
]
throwError $ err501
{ errBody = "userNotify: Not implemented yet"

View file

@ -121,11 +121,11 @@ selectAuthOverviews
-> PGS.Connection -- ^ Connection Handler
-> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do
liftIO $ map fromDatabase <$> head <$> runSelect conn (proc () -> do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< ()
restrict -< aduid .== C.constant uid
returnA -< (adid, adcomment, admethod)
returnA -< (adid, aduid, adcomment, admethod)
)
@ -133,13 +133,12 @@ selectAuthOverviewById
:: Int -- ^ Auth Data ID
-> PGS.Connection -- ^ Connection Handler
-> MateHandler AuthOverview
selectAuthOverviews aid conn = do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
selectAuthOverviewById aid conn = do
liftIO $ fromDatabase <$> head <$> runSelect conn (limit 1 $ proc () -> do
(adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< ()
restrict -< adid .== C.constant aid
limit 1
returnA -< (adid, adcomment, admethod)
returnA -< (adid, aduid, adcomment, admethod)
)

View file

@ -199,6 +199,7 @@ instance FromDatabase AuthData where
data AuthOverview = AuthOverview
{ authOverviewId :: Int
, authOverviewUser :: Int
, authOverviewComment :: T.Text
, authOverviewMethod :: AuthMethod
}
@ -218,7 +219,7 @@ instance FromJSON AuthOverview
instance FromDatabase AuthOverview where
type OutTuple AuthOverview = (Int, T.Text, Int)
type OutTuple AuthOverview = (Int, Int, T.Text, Int)
fromDatabase (id_, comm, method) =
AuthOverview id_ comm (toEnum method)
fromDatabase (id_, uid, comm, method) =
AuthOverview id_ uid comm (toEnum method)