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: build-tool-depends:
hspec-discover:hspec-discover == 2.* hspec-discover:hspec-discover == 2.*
other-modules: other-modules:
Spec
TestUtil TestUtil
AppMainSpec AppMainSpec

View file

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

View file

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

View file

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

View file

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