This commit is contained in:
nek0 2021-07-12 13:29:40 +02:00
parent 594de43cd8
commit 9358d21752
12 changed files with 167 additions and 80 deletions

View file

@ -3,36 +3,40 @@ module AppTypes.Configuration where
import qualified Data.Text as T import qualified Data.Text as T
import Data.YAML as Y import Data.Yaml as Y
import Options.Applicative as O import Options.Applicative as O
data ServerConfig = ServerConfig data ServerConfig = ServerConfig
{ configDbHost :: T.Text { configDbHost :: T.Text
, configDbPort :: Word , configDbPort :: Word
, configDbName :: T.Text , configDbName :: T.Text
, configDbUser :: T.Text , configDbUser :: T.Text
, configDbPasswd :: T.Text , configDbPasswd :: T.Text
, configCurrencySymbol :: T.Text , configCurrencySymbol :: T.Text
, configListenPort :: Word , configCurrencyFraction :: Word
, configListenHost :: T.Text , configListenPort :: Word
, configListenHost :: T.Text
-- , configMaxConnectionsPerClient :: Word -- , configMaxConnectionsPerClient :: Word
, configBlockRegistration :: Bool , configBlockRegistration :: Bool
, configSendmailPath :: FilePath
} }
deriving (Show) deriving (Show)
instance FromYAML ServerConfig where instance FromJSON ServerConfig where
parseYAML = withMap "Configuration" $ \m -> ServerConfig parseJSON (Object m) = ServerConfig
<$> m .: "db_host" <$> m .: "db_host"
<*> m .: "db_port" <*> m .: "db_port"
<*> m .: "db_name" <*> m .: "db_name"
<*> m .: "db_user" <*> m .: "db_user"
<*> m .: "db_passwd" <*> m .: "db_passwd"
<*> m .: "currency" <*> m .: "currency"
<*> m .: "currency_fraction"
<*> m .: "listen_port" <*> m .: "listen_port"
<*> m .:? "listen_host" .!= "127.0.0.1" <*> m .:? "listen_host" .!= "127.0.0.1"
-- <*> m .:? "max_connections_per_client" .!= 10 -- <*> m .:? "max_connections_per_client" .!= 10
<*> m .: "block_registration" <*> m .: "block_registration"
<*> m .: "sendmail_path"
data Options = Options data Options = Options
{ optConfigLocation :: T.Text { optConfigLocation :: T.Text

View file

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -11,30 +10,26 @@ import Servant
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
import Data.Set as S (empty) import Data.Set as S (empty)
import qualified Data.Map.Lazy as M
import Data.ByteString.Lazy as BL hiding (putStrLn)
import Data.ByteString.Char8 as B8 hiding (putStrLn) import Data.ByteString.Char8 as B8 hiding (putStrLn)
import qualified Data.Text as T import qualified Data.Text as T
import Data.String import Data.String
import Data.YAML import Data.Yaml
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.IP import Data.IP
import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Migration import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util import Database.PostgreSQL.Simple.Util
import Network.Socket (defaultPort)
import Network.Wai import Network.Wai
import Network.Wai.Logger import Network.Wai.Logger
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Throttle import Network.Wai.Middleware.Throttle
import Network.Socket (SockAddr(..), defaultPort)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Options.Applicative import Options.Applicative
@ -59,12 +54,12 @@ import Paths_mateamt (version)
main :: IO () main :: IO ()
main = do main = do
(Options confLoc tMigLoc) <- execParser opts (Options confLoc tMigLoc) <- execParser opts
raw <- BL.readFile (T.unpack confLoc) raw <- B8.readFile (T.unpack confLoc)
case decode1 raw of case decodeEither' raw of
Left (loc, msg) -> Left msg ->
error (T.unpack $ confLoc <> ":" <> error (T.unpack $ confLoc <> ":" <>
fromString (prettyPosWithSource loc raw " error") <> " error: " <>
fromString msg fromString (prettyPrintParseException msg)
) )
Right Right
(ServerConfig (ServerConfig
@ -74,10 +69,12 @@ main = do
db_user db_user
db_passwd db_passwd
sym sym
currency_fraction
lport lport
lhost lhost
-- max_conn_per_client -- max_conn_per_client
block_registration block_registration
sendmail_path
) -> do ) -> do
conn <- connectPostgreSQL ( conn <- connectPostgreSQL (
"host='" <> fromString (T.unpack db_host) <> "' " <> "host='" <> fromString (T.unpack db_host) <> "' " <>
@ -92,7 +89,7 @@ main = do
unless migrationsExist $ do unless migrationsExist $ do
withTransaction conn $ withTransaction conn $
void $ do void $ do
runMigration $ void $ runMigration $
MigrationContext MigrationInitialization True conn MigrationContext MigrationInitialization True conn
initDB conn initDB conn
-- validate Migrations -- validate Migrations
@ -127,20 +124,22 @@ main = do
{ rsConnection = conn { rsConnection = conn
, rsTicketStore = store , rsTicketStore = store
, rsCurrencySymbol = sym , rsCurrencySymbol = sym
, rsCurrencyFraction = currency_fraction
, rsSoftwareVersion = T.pack (showVersion version) , rsSoftwareVersion = T.pack (showVersion version)
, rsSendmailPath = sendmail_path
} }
expirationSpec = TimeSpec 5 0 -- five seconds expirationSpec = TimeSpec 5 0 -- five seconds
throttleSettings = (defaultThrottleSettings expirationSpec) throt = (defaultThrottleSettings expirationSpec)
{ throttleSettingsRate = 10 { throttleSettingsRate = 10
, throttleSettingsPeriod = 1000 , throttleSettingsPeriod = 1000
} }
th <- initCustomThrottler throttleSettings th <- initCustomThrottler throt
(\req -> (\req ->
let headers = requestHeaders req let headers = requestHeaders req
in case lookup "x-forwarded-for" headers of in case lookup "x-forwarded-for" headers of
Just addrs -> Just addrs ->
let addr = fst (B8.break (== ',') addrs) let xaddr = fst (B8.break (== ',') addrs)
in Right $ Address $ toSockAddr (read (B8.unpack addr), defaultPort) in Right $ Address $ toSockAddr (read (B8.unpack xaddr), defaultPort)
Nothing -> Right $ Address $ remoteHost req Nothing -> Right $ Address $ remoteHost req
) )
runSettings settings (throttle th (app block_registration initState)) runSettings settings (throttle th (app block_registration initState))

View file

@ -7,4 +7,6 @@ listen_port: 8000
#listen_host: "127.0.0.1" #listen_host: "127.0.0.1"
#max_connections_per_client: 10 #max_connections_per_client: 10
currency: "meow" currency: "meow"
currency_fraction: 2
block_registration: false block_registration: false
sendmail_path: "/run/wrappers/bin/sendmail"

View file

@ -101,6 +101,9 @@ library
, stm , stm
, pureMD5 , pureMD5
, extra , extra
, haskell-gettext
, mime-mail
, directory
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -141,12 +144,11 @@ executable mateamt
, wai , wai
, wai-logger , wai-logger
, wai-middleware-throttle , wai-middleware-throttle
, HsYAML >= 0.2.1.0 , yaml
, optparse-applicative , optparse-applicative
, case-insensitive , case-insensitive
, iproute , iproute
, clock , clock
, haskell-gettext
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010

View file

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Control.Meta where module Control.Meta where
import Control.Monad.Reader (ask) import Control.Monad.Reader (asks)
-- internal imports -- internal imports
@ -9,7 +9,8 @@ import Types
metaGet :: MateHandler MetaInformation metaGet :: MateHandler MetaInformation
metaGet = do metaGet = do
(ReadState _ _ symbol version) <- ask symbol <- asks rsCurrencySymbol
version <- asks rsSoftwareVersion
return (MetaInformation return (MetaInformation
{ metaInfoVersion = version { metaInfoVersion = version
, metaInfoCurrency = symbol , metaInfoCurrency = symbol

View file

@ -13,8 +13,6 @@ 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
import Text.Printf (printf) import Text.Printf (printf)
@ -23,7 +21,6 @@ import Text.Printf (printf)
import Types import Types
import Model import Model
import Control.Role
import Util import Util
userNew userNew
@ -167,9 +164,9 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
) )
) )
boughtItems boughtItems
currencyFrac <- return 2 -- TODO: Make currency fractions configurable currencyFrac <- asks rsCurrencyFraction
currencySymb <- asks rsCurrencySymbol currencySymb <- asks rsCurrencySymbol
let messageText = mconcat $ map (<> ("\n" :: String)) $ let messageText = T.pack $ mconcat $ map (<> ("\n")) $
[ printf (__ "Hello %s,") (userDetailsIdent userDetails) [ printf (__ "Hello %s,") (userDetailsIdent userDetails)
, "" , ""
, printf (__ "Your authentication key with the comment \"%s\"\ , printf (__ "Your authentication key with the comment \"%s\"\
@ -190,22 +187,33 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
ident ident
price price
) )
degestedDetails digestedDetails
) )
++ ++
[ "" [ ""
, printf (__ "For a total price of %s%s") <> , printf (__ "For a total price of %s%s") <>
(fprint "%f." <> (printf
(fprint "%d" currencyFrac) $ ("%f." <>
fromIntegral (printf "%d" currencyFrac :: String))
(foldl (\acc (_, _, p) -> acc + p) ((fromIntegral $
0 foldl (\acc (_, _, p) -> acc + p)
digestedDetails 0
) / digestedDetails
(10 ^ currencyFrac) -- TODO: Make currency fractions configurable ) /
) <> (fromIntegral $ 10 ^ currencyFrac)
(printf "%s" currencySymb) :: Float ))
currencySymb
, ""
, (__ "Enjoy your purchased items!\n\nSincerely,\nMateamt")
] ]
throwError $ err501 case userDetailsEmail userDetails of
{ errBody = "userNotify: Not implemented yet" Just _ -> do
} sendUserNotification
userDetails
(__ "Purchase notification")
messageText
Nothing ->
return ()
-- throwError $ err501
-- { errBody = "userNotify: Not implemented yet"
-- }

View file

@ -60,7 +60,7 @@ insertNewEmptyAmount
-> ProductSubmit -- ^ submitted product data -> ProductSubmit -- ^ submitted product data
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _) conn = insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn =
liftIO $ do liftIO $ do
now <- getCurrentTime now <- getCurrentTime
fmap head $ runInsert_ conn $ Insert fmap head $ runInsert_ conn $ Insert

View file

@ -9,7 +9,7 @@ import qualified Data.Text as T hiding (head, foldl, map)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Data.Profunctor.Product (p9) import Data.Profunctor.Product (p10)
import Data.Maybe import Data.Maybe
@ -39,6 +39,7 @@ initProduct = mconcat
, "product_avatar INTEGER," , "product_avatar INTEGER,"
, "product_supplier INTEGER," , "product_supplier INTEGER,"
, "product_max_amount INTEGER NOT NULL," , "product_max_amount INTEGER NOT NULL,"
, "product_min_amount INTEGER NOT NULL,"
, "product_amount_per_crate INTEGER NOT NULL," , "product_amount_per_crate INTEGER NOT NULL,"
, "product_price_per_crate INTEGER," , "product_price_per_crate INTEGER,"
, "product_art_nr TEXT" , "product_art_nr TEXT"
@ -53,6 +54,7 @@ productTable :: Table
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , FieldNullable SqlText
) )
@ -63,17 +65,19 @@ productTable :: Table
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , FieldNullable SqlText
) )
productTable = table "product" ( productTable = table "product" (
p9 p10
( tableField "product_id" ( tableField "product_id"
, tableField "product_ident" , tableField "product_ident"
, tableField "product_ml" , tableField "product_ml"
, tableField "product_avatar" , tableField "product_avatar"
, tableField "product_supplier" , tableField "product_supplier"
, tableField "product_max_amount" , tableField "product_max_amount"
, tableField "product_min_amount"
, tableField "product_amount_per_crate" , tableField "product_amount_per_crate"
, tableField "product_price_per_crate" , tableField "product_price_per_crate"
, tableField "product_art_nr" , tableField "product_art_nr"
@ -97,7 +101,7 @@ productSelectSingle pid conn = do
prods <- liftIO $ map fromDatabase <$> runSelect conn prods <- liftIO $ map fromDatabase <$> runSelect conn
( limit 1 ( limit 1
(keepWhen ( (keepWhen (
\(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid \(id_, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
) <<< queryTable productTable) ) <<< queryTable productTable)
) )
case prods of case prods of
@ -125,6 +129,7 @@ produceProductOverviews
, Column (Nullable PGInt4) , Column (Nullable PGInt4)
, Column PGInt4 , Column PGInt4
, Column PGInt4 , Column PGInt4
, Column PGInt4
, Column (Nullable PGInt4) , Column (Nullable PGInt4)
, Column (Nullable PGText) , Column (Nullable PGText)
, Column PGInt4 , Column PGInt4
@ -132,11 +137,11 @@ produceProductOverviews
) )
produceProductOverviews refine = produceProductOverviews refine =
proc () -> do proc () -> do
(p, i2, i6, i7, i8, i9, i11, i12, i13, a3, a4) (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4)
<- orderBy (asc (\(_, a2, _, _, _, _, _, _, _, _, _) -> a2)) (leftJoinF <- orderBy (asc (\(_, a2, _, _, _, _, _, _, _, _, _, _) -> a2)) (leftJoinF
(\(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13) (\(pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13)
(_, _, ai3, ai4, _) -> (_, _, ai3, ai4, _) ->
(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4) (pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4)
) )
(const (const
( C.constant (0 :: Int) :: Column PGInt4 ( C.constant (0 :: Int) :: Column PGInt4
@ -146,13 +151,14 @@ produceProductOverviews refine =
, C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) , C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4)
, C.constant (0 :: Int) :: Column PGInt4 , C.constant (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4 , C.constant (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4
, C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) , C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4)
, C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText) , C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText)
, C.constant (0 :: Int) :: Column PGInt4 , C.constant (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4 , C.constant (0 :: Int) :: Column PGInt4
) )
) )
(\(pid, _, _, _, _, _, _, _, _) (\(pid, _, _, _, _, _, _, _, _, _)
(aid, _, _, _, _) -> (aid, _, _, _, _) ->
pid .== aid pid .== aid
) )
@ -177,7 +183,7 @@ produceProductOverviews refine =
AllProducts -> C.constant True AllProducts -> C.constant True
AvailableProducts -> a3 ./= (C.constant (0 :: Int) :: Column PGInt4) AvailableProducts -> a3 ./= (C.constant (0 :: Int) :: Column PGInt4)
DepletedProducts -> a3 .== (C.constant (0 :: Int) :: Column PGInt4) DepletedProducts -> a3 .== (C.constant (0 :: Int) :: Column PGInt4)
returnA -< (p, i2, i6, i7, i8, i9, i11, i12, i13, a3, a4) returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4)
queryAmounts queryAmounts
:: PGS.Connection :: PGS.Connection
@ -199,13 +205,14 @@ generateProductOverview
, Maybe Int , Maybe Int
, Int , Int
, Int , Int
, Int
, Maybe Int , Maybe Int
, Maybe Text , Maybe Text
, Int , Int
, Int , Int
) )
-> MateHandler ProductOverview -> MateHandler ProductOverview
generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do generateProductOverview conn (i1, i2, i3, i4, i5, i6, i6a, i7, i8, i9, a3, a4) = do
amounts <- liftIO $ queryAmounts conn i1 amounts <- liftIO $ queryAmounts conn i1
let ii5 = snd $ let ii5 = snd $
foldl foldl
@ -224,7 +231,7 @@ generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do
(0, 0) (0, 0)
(Prelude.reverse amounts) (Prelude.reverse amounts)
return $ ProductOverview return $ ProductOverview
i1 i2 a4 a3 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 i1 i2 a4 a3 ii5 i3 i4 i5 i6 i6a ii10 i7 i8 i9
productOverviewSelectSingle productOverviewSelectSingle
:: Int :: Int
@ -234,7 +241,7 @@ productOverviewSelectSingle pid conn = do
prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts) prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts)
head <$> mapM head <$> mapM
(generateProductOverview conn) (generateProductOverview conn)
(Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods) (Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
productShortOverviewSelect productShortOverviewSelect
@ -251,13 +258,14 @@ productShortOverviewSelect refine conn = do
, Maybe Int , Maybe Int
, Int , Int
, Int , Int
, Int
, Maybe Int , Maybe Int
, Maybe Text , Maybe Text
, Int , Int
, Int , Int
)] )]
mapM mapM
(\(i1, i2, i3, i4, _, _, _, _, _, a3, a4) -> (\(i1, i2, i3, i4, _, _, _, _, _, _, a3, a4) ->
return $ ProductShortOverview return $ ProductShortOverview
i1 i2 a4 a3 i3 i4 i1 i2 a4 a3 i3 i4
) )
@ -268,7 +276,7 @@ insertProduct
:: ProductSubmit :: ProductSubmit
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn = insertProduct (ProductSubmit ident _ ml ava sup maxi mini apc ppc artnr) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = productTable { iTable = productTable
, iRows = , iRows =
@ -279,12 +287,13 @@ insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn =
, C.constant ava , C.constant ava
, C.constant sup , C.constant sup
, C.constant maxi , C.constant maxi
, C.constant mini
, C.constant apc , C.constant apc
, C.constant ppc , C.constant ppc
, C.constant artnr , C.constant artnr
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_)
, iOnConflict = Nothing , iOnConflict = Nothing
} }

View file

@ -154,8 +154,8 @@ instance FromDatabase Token where
type OutTuple Token = (T.Text, Int, UTCTime, Int) type OutTuple Token = (T.Text, Int, UTCTime, Int)
fromDatabase (string, usr, exp, method) = fromDatabase (string, usr, expiry, method) =
Token string usr exp (toEnum method) Token string usr expiry (toEnum method)
type TicketStore = TVar (S.Set Ticket) type TicketStore = TVar (S.Set Ticket)

View file

@ -22,6 +22,7 @@ data Product = Product
, productAvatar :: Maybe Int , productAvatar :: Maybe Int
, productSupplier :: Maybe Int , productSupplier :: Maybe Int
, productMaxAmount :: Int , productMaxAmount :: Int
, productMinAmount :: Int
-- , productTotalBought :: Int -- , productTotalBought :: Int
, productAmountPerCrate :: Int , productAmountPerCrate :: Int
, productPricePerCrate :: Maybe Int , productPricePerCrate :: Maybe Int
@ -36,18 +37,18 @@ instance FromJSON Product
instance ToDatabase Product where instance ToDatabase Product where
type InTuple Product = type InTuple Product =
(Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text) (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Int, Maybe Int, Maybe T.Text)
toDatabase (Product id_ ident ml maid msid maxa apc ppc artnr) = toDatabase (Product id_ ident ml maid msid maxa mina apc ppc artnr) =
(id_, ident, ml, maid, msid, maxa, apc, ppc, artnr) (id_, ident, ml, maid, msid, maxa, mina, apc, ppc, artnr)
instance FromDatabase Product where instance FromDatabase Product where
type OutTuple Product = type OutTuple Product =
(Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text) (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Int, Maybe Int, Maybe T.Text)
fromDatabase (id_, ident, ml, maid, msid, maxa, apc, ppc, artnr) = fromDatabase (id_, ident, ml, maid, msid, maxa, mina, apc, ppc, artnr) =
Product id_ ident ml maid msid maxa apc ppc artnr Product id_ ident ml maid msid maxa mina apc ppc artnr
data ProductOverview = ProductOverview data ProductOverview = ProductOverview
@ -60,6 +61,7 @@ data ProductOverview = ProductOverview
, productOverviewAvatar :: Maybe Int , productOverviewAvatar :: Maybe Int
, productOverviewSupplier :: Maybe Int , productOverviewSupplier :: Maybe Int
, productOverviewMaxAmount :: Int , productOverviewMaxAmount :: Int
, productOverviewMinAmount :: Int
, productOverviewTotalBought :: Int , productOverviewTotalBought :: Int
, productOverviewAmountPerCrate :: Int , productOverviewAmountPerCrate :: Int
, productOverviewPricePerCrate :: Maybe Int , productOverviewPricePerCrate :: Maybe Int
@ -103,6 +105,7 @@ data ProductSubmit = ProductSubmit
, productSubmitAvatar :: Maybe Int , productSubmitAvatar :: Maybe Int
, productSubmitSupplier :: Maybe Int , productSubmitSupplier :: Maybe Int
, productSubmitMaxAmount :: Int , productSubmitMaxAmount :: Int
, productSubmitMinAmount :: Int
-- , productSubmitTotalBought :: Int -- , productSubmitTotalBought :: Int
, productSubmitAmountPerCrate :: Int , productSubmitAmountPerCrate :: Int
, productSubmitPricePerCrate :: Maybe Int , productSubmitPricePerCrate :: Maybe Int

View file

@ -13,10 +13,12 @@ import Database.PostgreSQL.Simple (Connection)
import Types.Auth (TicketStore) import Types.Auth (TicketStore)
data ReadState = ReadState data ReadState = ReadState
{ rsConnection :: Connection { rsConnection :: Connection
, rsTicketStore :: TicketStore , rsTicketStore :: TicketStore
, rsCurrencySymbol :: T.Text , rsCurrencySymbol :: T.Text
, rsSoftwareVersion :: T.Text , rsCurrencyFraction :: Word
, rsSoftwareVersion :: T.Text
, rsSendmailPath :: FilePath
} }
type MateHandler = ReaderT ReadState Handler type MateHandler = ReaderT ReadState Handler

View file

@ -1,20 +1,35 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Util where module Util where
import Opaleye import Opaleye
import Data.ByteString.Lazy (fromStrict)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Profunctor.Product.Default (Default) import Data.Profunctor.Product.Default (Default)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Network.Mail.Mime
import System.Directory (doesFileExist)
-- internal imports -- internal imports
import Model import Model
import Types
printSql :: Default Unpackspec a a => Select a -> IO () printSql :: Default Unpackspec a a => Select a -> IO ()
printSql = putStrLn . fromMaybe "Empty query" . showSqlForPostgres printSql = putStrLn . fromMaybe "Empty query" . showSqlForPostgres
@ -34,3 +49,45 @@ initDB conn = do
-- This is only a dummy function. -- This is only a dummy function.
-- TODO: Replace with proper translation function(s)! -- TODO: Replace with proper translation function(s)!
__ = id __ = id
sendUserNotification
:: UserDetails -- ^ The recipient
-> T.Text -- ^ The mail subject
-> T.Text -- ^ The mail body
-> MateHandler ()
sendUserNotification recipient subject message =
case userDetailsEmail recipient of
Just email ->
sendNotification (Mail
{ mailFrom = Address Nothing "noreply"
, mailTo =
[ Address
(Just $ userDetailsIdent recipient)
(email)
]
, mailCc = []
, mailBcc = []
, mailHeaders = [("Subject", subject)]
, mailParts =
[[ Part
{ partType = "text/plain; charset=utf-8"
, partEncoding = None
, partDisposition = DefaultDisposition
, partHeaders = []
, partContent = PartContent (fromStrict $ E.encodeUtf8 message)
}
]]
}
)
Nothing ->
return ()
sendNotification mail = do
sendmail <- asks rsSendmailPath
liftIO $ do
existence <- doesFileExist sendmail
if existence
then
renderSendMailCustom sendmail [] mail
else
print "Warning: sending notification failed: Sendmail not present!"