fix compilation errors
This commit is contained in:
parent
28709dd0cf
commit
2e958c0927
5 changed files with 27 additions and 22 deletions
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue