expand
This commit is contained in:
parent
594de43cd8
commit
9358d21752
12 changed files with 167 additions and 80 deletions
|
|
@ -3,36 +3,40 @@ module AppTypes.Configuration where
|
|||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.YAML as Y
|
||||
import Data.Yaml as Y
|
||||
|
||||
import Options.Applicative as O
|
||||
|
||||
data ServerConfig = ServerConfig
|
||||
{ configDbHost :: T.Text
|
||||
, configDbPort :: Word
|
||||
, configDbName :: T.Text
|
||||
, configDbUser :: T.Text
|
||||
, configDbPasswd :: T.Text
|
||||
, configCurrencySymbol :: T.Text
|
||||
, configListenPort :: Word
|
||||
, configListenHost :: T.Text
|
||||
{ configDbHost :: T.Text
|
||||
, configDbPort :: Word
|
||||
, configDbName :: T.Text
|
||||
, configDbUser :: T.Text
|
||||
, configDbPasswd :: T.Text
|
||||
, configCurrencySymbol :: T.Text
|
||||
, configCurrencyFraction :: Word
|
||||
, configListenPort :: Word
|
||||
, configListenHost :: T.Text
|
||||
-- , configMaxConnectionsPerClient :: Word
|
||||
, configBlockRegistration :: Bool
|
||||
, configSendmailPath :: FilePath
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance FromYAML ServerConfig where
|
||||
parseYAML = withMap "Configuration" $ \m -> ServerConfig
|
||||
instance FromJSON ServerConfig where
|
||||
parseJSON (Object m) = ServerConfig
|
||||
<$> m .: "db_host"
|
||||
<*> m .: "db_port"
|
||||
<*> m .: "db_name"
|
||||
<*> m .: "db_user"
|
||||
<*> m .: "db_passwd"
|
||||
<*> m .: "currency"
|
||||
<*> m .: "currency_fraction"
|
||||
<*> m .: "listen_port"
|
||||
<*> m .:? "listen_host" .!= "127.0.0.1"
|
||||
-- <*> m .:? "max_connections_per_client" .!= 10
|
||||
<*> m .: "block_registration"
|
||||
<*> m .: "sendmail_path"
|
||||
|
||||
data Options = Options
|
||||
{ optConfigLocation :: T.Text
|
||||
|
|
|
|||
35
app/Main.hs
35
app/Main.hs
|
|
@ -1,5 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
|
@ -11,30 +10,26 @@ import Servant
|
|||
import Servant.Server.Experimental.Auth
|
||||
|
||||
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 qualified Data.Text as T
|
||||
import Data.String
|
||||
import Data.YAML
|
||||
import Data.Yaml
|
||||
import Data.Version (showVersion)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.IP
|
||||
|
||||
import Database.PostgreSQL.Simple
|
||||
import Database.PostgreSQL.Simple.Migration
|
||||
import Database.PostgreSQL.Simple.Util
|
||||
|
||||
import Network.Socket (defaultPort)
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Logger
|
||||
import Network.Wai.Handler.Warp
|
||||
import Network.Wai.Middleware.Throttle
|
||||
import Network.Socket (SockAddr(..), defaultPort)
|
||||
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import Options.Applicative
|
||||
|
|
@ -59,12 +54,12 @@ import Paths_mateamt (version)
|
|||
main :: IO ()
|
||||
main = do
|
||||
(Options confLoc tMigLoc) <- execParser opts
|
||||
raw <- BL.readFile (T.unpack confLoc)
|
||||
case decode1 raw of
|
||||
Left (loc, msg) ->
|
||||
raw <- B8.readFile (T.unpack confLoc)
|
||||
case decodeEither' raw of
|
||||
Left msg ->
|
||||
error (T.unpack $ confLoc <> ":" <>
|
||||
fromString (prettyPosWithSource loc raw " error") <>
|
||||
fromString msg
|
||||
" error: " <>
|
||||
fromString (prettyPrintParseException msg)
|
||||
)
|
||||
Right
|
||||
(ServerConfig
|
||||
|
|
@ -74,10 +69,12 @@ main = do
|
|||
db_user
|
||||
db_passwd
|
||||
sym
|
||||
currency_fraction
|
||||
lport
|
||||
lhost
|
||||
-- max_conn_per_client
|
||||
block_registration
|
||||
sendmail_path
|
||||
) -> do
|
||||
conn <- connectPostgreSQL (
|
||||
"host='" <> fromString (T.unpack db_host) <> "' " <>
|
||||
|
|
@ -92,7 +89,7 @@ main = do
|
|||
unless migrationsExist $ do
|
||||
withTransaction conn $
|
||||
void $ do
|
||||
runMigration $
|
||||
void $ runMigration $
|
||||
MigrationContext MigrationInitialization True conn
|
||||
initDB conn
|
||||
-- validate Migrations
|
||||
|
|
@ -127,20 +124,22 @@ main = do
|
|||
{ rsConnection = conn
|
||||
, rsTicketStore = store
|
||||
, rsCurrencySymbol = sym
|
||||
, rsCurrencyFraction = currency_fraction
|
||||
, rsSoftwareVersion = T.pack (showVersion version)
|
||||
, rsSendmailPath = sendmail_path
|
||||
}
|
||||
expirationSpec = TimeSpec 5 0 -- five seconds
|
||||
throttleSettings = (defaultThrottleSettings expirationSpec)
|
||||
throt = (defaultThrottleSettings expirationSpec)
|
||||
{ throttleSettingsRate = 10
|
||||
, throttleSettingsPeriod = 1000
|
||||
}
|
||||
th <- initCustomThrottler throttleSettings
|
||||
th <- initCustomThrottler throt
|
||||
(\req ->
|
||||
let headers = requestHeaders req
|
||||
in case lookup "x-forwarded-for" headers of
|
||||
Just addrs ->
|
||||
let addr = fst (B8.break (== ',') addrs)
|
||||
in Right $ Address $ toSockAddr (read (B8.unpack addr), defaultPort)
|
||||
let xaddr = fst (B8.break (== ',') addrs)
|
||||
in Right $ Address $ toSockAddr (read (B8.unpack xaddr), defaultPort)
|
||||
Nothing -> Right $ Address $ remoteHost req
|
||||
)
|
||||
runSettings settings (throttle th (app block_registration initState))
|
||||
|
|
|
|||
|
|
@ -7,4 +7,6 @@ listen_port: 8000
|
|||
#listen_host: "127.0.0.1"
|
||||
#max_connections_per_client: 10
|
||||
currency: "meow"
|
||||
currency_fraction: 2
|
||||
block_registration: false
|
||||
sendmail_path: "/run/wrappers/bin/sendmail"
|
||||
|
|
|
|||
|
|
@ -101,6 +101,9 @@ library
|
|||
, stm
|
||||
, pureMD5
|
||||
, extra
|
||||
, haskell-gettext
|
||||
, mime-mail
|
||||
, directory
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -141,12 +144,11 @@ executable mateamt
|
|||
, wai
|
||||
, wai-logger
|
||||
, wai-middleware-throttle
|
||||
, HsYAML >= 0.2.1.0
|
||||
, yaml
|
||||
, optparse-applicative
|
||||
, case-insensitive
|
||||
, iproute
|
||||
, clock
|
||||
, haskell-gettext
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Control.Meta where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.Reader (asks)
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
@ -9,7 +9,8 @@ import Types
|
|||
|
||||
metaGet :: MateHandler MetaInformation
|
||||
metaGet = do
|
||||
(ReadState _ _ symbol version) <- ask
|
||||
symbol <- asks rsCurrencySymbol
|
||||
version <- asks rsSoftwareVersion
|
||||
return (MetaInformation
|
||||
{ metaInfoVersion = version
|
||||
, metaInfoCurrency = symbol
|
||||
|
|
|
|||
|
|
@ -13,8 +13,6 @@ import Data.Time (getCurrentTime, utctDay)
|
|||
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Text.Printf (printf)
|
||||
|
|
@ -23,7 +21,6 @@ import Text.Printf (printf)
|
|||
|
||||
import Types
|
||||
import Model
|
||||
import Control.Role
|
||||
import Util
|
||||
|
||||
userNew
|
||||
|
|
@ -167,9 +164,9 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
|
|||
)
|
||||
)
|
||||
boughtItems
|
||||
currencyFrac <- return 2 -- TODO: Make currency fractions configurable
|
||||
currencyFrac <- asks rsCurrencyFraction
|
||||
currencySymb <- asks rsCurrencySymbol
|
||||
let messageText = mconcat $ map (<> ("\n" :: String)) $
|
||||
let messageText = T.pack $ mconcat $ map (<> ("\n")) $
|
||||
[ printf (__ "Hello %s,") (userDetailsIdent userDetails)
|
||||
, ""
|
||||
, printf (__ "Your authentication key with the comment \"%s\"\
|
||||
|
|
@ -190,22 +187,33 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
|
|||
ident
|
||||
price
|
||||
)
|
||||
degestedDetails
|
||||
digestedDetails
|
||||
)
|
||||
++
|
||||
[ ""
|
||||
, printf (__ "For a total price of %s%s") <>
|
||||
(fprint "%f." <>
|
||||
(fprint "%d" currencyFrac) $
|
||||
fromIntegral
|
||||
(foldl (\acc (_, _, p) -> acc + p)
|
||||
0
|
||||
digestedDetails
|
||||
) /
|
||||
(10 ^ currencyFrac) -- TODO: Make currency fractions configurable
|
||||
) <>
|
||||
(printf "%s" currencySymb)
|
||||
(printf
|
||||
("%f." <>
|
||||
(printf "%d" currencyFrac :: String))
|
||||
((fromIntegral $
|
||||
foldl (\acc (_, _, p) -> acc + p)
|
||||
0
|
||||
digestedDetails
|
||||
) /
|
||||
(fromIntegral $ 10 ^ currencyFrac)
|
||||
:: Float ))
|
||||
currencySymb
|
||||
, ""
|
||||
, (__ "Enjoy your purchased items!\n\nSincerely,\nMateamt")
|
||||
]
|
||||
throwError $ err501
|
||||
{ errBody = "userNotify: Not implemented yet"
|
||||
}
|
||||
case userDetailsEmail userDetails of
|
||||
Just _ -> do
|
||||
sendUserNotification
|
||||
userDetails
|
||||
(__ "Purchase notification")
|
||||
messageText
|
||||
Nothing ->
|
||||
return ()
|
||||
-- throwError $ err501
|
||||
-- { errBody = "userNotify: Not implemented yet"
|
||||
-- }
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ insertNewEmptyAmount
|
|||
-> ProductSubmit -- ^ submitted product data
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _) conn =
|
||||
insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn =
|
||||
liftIO $ do
|
||||
now <- getCurrentTime
|
||||
fmap head $ runInsert_ conn $ Insert
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import qualified Data.Text as T hiding (head, foldl, map)
|
|||
|
||||
import Data.Time (getCurrentTime)
|
||||
|
||||
import Data.Profunctor.Product (p9)
|
||||
import Data.Profunctor.Product (p10)
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
|
|
@ -39,6 +39,7 @@ initProduct = mconcat
|
|||
, "product_avatar INTEGER,"
|
||||
, "product_supplier INTEGER,"
|
||||
, "product_max_amount INTEGER NOT NULL,"
|
||||
, "product_min_amount INTEGER NOT NULL,"
|
||||
, "product_amount_per_crate INTEGER NOT NULL,"
|
||||
, "product_price_per_crate INTEGER,"
|
||||
, "product_art_nr TEXT"
|
||||
|
|
@ -53,6 +54,7 @@ productTable :: Table
|
|||
, FieldNullable SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlText
|
||||
)
|
||||
|
|
@ -63,17 +65,19 @@ productTable :: Table
|
|||
, FieldNullable SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlText
|
||||
)
|
||||
productTable = table "product" (
|
||||
p9
|
||||
p10
|
||||
( tableField "product_id"
|
||||
, tableField "product_ident"
|
||||
, tableField "product_ml"
|
||||
, tableField "product_avatar"
|
||||
, tableField "product_supplier"
|
||||
, tableField "product_max_amount"
|
||||
, tableField "product_min_amount"
|
||||
, tableField "product_amount_per_crate"
|
||||
, tableField "product_price_per_crate"
|
||||
, tableField "product_art_nr"
|
||||
|
|
@ -97,7 +101,7 @@ productSelectSingle pid conn = do
|
|||
prods <- liftIO $ map fromDatabase <$> runSelect conn
|
||||
( limit 1
|
||||
(keepWhen (
|
||||
\(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
|
||||
\(id_, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
|
||||
) <<< queryTable productTable)
|
||||
)
|
||||
case prods of
|
||||
|
|
@ -125,6 +129,7 @@ produceProductOverviews
|
|||
, Column (Nullable PGInt4)
|
||||
, Column PGInt4
|
||||
, Column PGInt4
|
||||
, Column PGInt4
|
||||
, Column (Nullable PGInt4)
|
||||
, Column (Nullable PGText)
|
||||
, Column PGInt4
|
||||
|
|
@ -132,11 +137,11 @@ produceProductOverviews
|
|||
)
|
||||
produceProductOverviews refine =
|
||||
proc () -> do
|
||||
(p, i2, i6, i7, i8, i9, i11, i12, i13, a3, a4)
|
||||
<- orderBy (asc (\(_, a2, _, _, _, _, _, _, _, _, _) -> a2)) (leftJoinF
|
||||
(\(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13)
|
||||
(p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4)
|
||||
<- orderBy (asc (\(_, a2, _, _, _, _, _, _, _, _, _, _) -> a2)) (leftJoinF
|
||||
(\(pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13)
|
||||
(_, _, 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
|
||||
( C.constant (0 :: Int) :: Column PGInt4
|
||||
|
|
@ -146,13 +151,14 @@ produceProductOverviews refine =
|
|||
, 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 (Just (0 :: Int)) :: Column (Nullable PGInt4)
|
||||
, C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText)
|
||||
, C.constant (0 :: Int) :: Column PGInt4
|
||||
, C.constant (0 :: Int) :: Column PGInt4
|
||||
)
|
||||
)
|
||||
(\(pid, _, _, _, _, _, _, _, _)
|
||||
(\(pid, _, _, _, _, _, _, _, _, _)
|
||||
(aid, _, _, _, _) ->
|
||||
pid .== aid
|
||||
)
|
||||
|
|
@ -177,7 +183,7 @@ produceProductOverviews refine =
|
|||
AllProducts -> C.constant True
|
||||
AvailableProducts -> 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
|
||||
:: PGS.Connection
|
||||
|
|
@ -199,13 +205,14 @@ generateProductOverview
|
|||
, Maybe Int
|
||||
, Int
|
||||
, Int
|
||||
, Int
|
||||
, Maybe Int
|
||||
, Maybe Text
|
||||
, Int
|
||||
, Int
|
||||
)
|
||||
-> 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
|
||||
let ii5 = snd $
|
||||
foldl
|
||||
|
|
@ -224,7 +231,7 @@ generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do
|
|||
(0, 0)
|
||||
(Prelude.reverse amounts)
|
||||
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
|
||||
:: Int
|
||||
|
|
@ -234,7 +241,7 @@ productOverviewSelectSingle pid conn = do
|
|||
prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts)
|
||||
head <$> mapM
|
||||
(generateProductOverview conn)
|
||||
(Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
|
||||
(Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
|
||||
|
||||
|
||||
productShortOverviewSelect
|
||||
|
|
@ -251,13 +258,14 @@ productShortOverviewSelect refine conn = do
|
|||
, Maybe Int
|
||||
, Int
|
||||
, Int
|
||||
, Int
|
||||
, Maybe Int
|
||||
, Maybe Text
|
||||
, Int
|
||||
, Int
|
||||
)]
|
||||
mapM
|
||||
(\(i1, i2, i3, i4, _, _, _, _, _, a3, a4) ->
|
||||
(\(i1, i2, i3, i4, _, _, _, _, _, _, a3, a4) ->
|
||||
return $ ProductShortOverview
|
||||
i1 i2 a4 a3 i3 i4
|
||||
)
|
||||
|
|
@ -268,7 +276,7 @@ insertProduct
|
|||
:: ProductSubmit
|
||||
-> PGS.Connection
|
||||
-> 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
|
||||
{ iTable = productTable
|
||||
, iRows =
|
||||
|
|
@ -279,12 +287,13 @@ insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn =
|
|||
, C.constant ava
|
||||
, C.constant sup
|
||||
, C.constant maxi
|
||||
, C.constant mini
|
||||
, C.constant apc
|
||||
, C.constant ppc
|
||||
, C.constant artnr
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _) -> id_)
|
||||
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -154,8 +154,8 @@ instance FromDatabase Token where
|
|||
|
||||
type OutTuple Token = (T.Text, Int, UTCTime, Int)
|
||||
|
||||
fromDatabase (string, usr, exp, method) =
|
||||
Token string usr exp (toEnum method)
|
||||
fromDatabase (string, usr, expiry, method) =
|
||||
Token string usr expiry (toEnum method)
|
||||
|
||||
|
||||
type TicketStore = TVar (S.Set Ticket)
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ data Product = Product
|
|||
, productAvatar :: Maybe Int
|
||||
, productSupplier :: Maybe Int
|
||||
, productMaxAmount :: Int
|
||||
, productMinAmount :: Int
|
||||
-- , productTotalBought :: Int
|
||||
, productAmountPerCrate :: Int
|
||||
, productPricePerCrate :: Maybe Int
|
||||
|
|
@ -36,18 +37,18 @@ instance FromJSON Product
|
|||
instance ToDatabase Product where
|
||||
|
||||
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) =
|
||||
(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, mina, apc, ppc, artnr)
|
||||
|
||||
instance FromDatabase Product where
|
||||
|
||||
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) =
|
||||
Product 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 mina apc ppc artnr
|
||||
|
||||
|
||||
data ProductOverview = ProductOverview
|
||||
|
|
@ -60,6 +61,7 @@ data ProductOverview = ProductOverview
|
|||
, productOverviewAvatar :: Maybe Int
|
||||
, productOverviewSupplier :: Maybe Int
|
||||
, productOverviewMaxAmount :: Int
|
||||
, productOverviewMinAmount :: Int
|
||||
, productOverviewTotalBought :: Int
|
||||
, productOverviewAmountPerCrate :: Int
|
||||
, productOverviewPricePerCrate :: Maybe Int
|
||||
|
|
@ -103,6 +105,7 @@ data ProductSubmit = ProductSubmit
|
|||
, productSubmitAvatar :: Maybe Int
|
||||
, productSubmitSupplier :: Maybe Int
|
||||
, productSubmitMaxAmount :: Int
|
||||
, productSubmitMinAmount :: Int
|
||||
-- , productSubmitTotalBought :: Int
|
||||
, productSubmitAmountPerCrate :: Int
|
||||
, productSubmitPricePerCrate :: Maybe Int
|
||||
|
|
|
|||
|
|
@ -13,10 +13,12 @@ import Database.PostgreSQL.Simple (Connection)
|
|||
import Types.Auth (TicketStore)
|
||||
|
||||
data ReadState = ReadState
|
||||
{ rsConnection :: Connection
|
||||
, rsTicketStore :: TicketStore
|
||||
, rsCurrencySymbol :: T.Text
|
||||
, rsSoftwareVersion :: T.Text
|
||||
{ rsConnection :: Connection
|
||||
, rsTicketStore :: TicketStore
|
||||
, rsCurrencySymbol :: T.Text
|
||||
, rsCurrencyFraction :: Word
|
||||
, rsSoftwareVersion :: T.Text
|
||||
, rsSendmailPath :: FilePath
|
||||
}
|
||||
|
||||
type MateHandler = ReaderT ReadState Handler
|
||||
|
|
|
|||
57
src/Util.hs
57
src/Util.hs
|
|
@ -1,20 +1,35 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Util where
|
||||
|
||||
import Opaleye
|
||||
|
||||
import Data.ByteString.Lazy (fromStrict)
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Data.Profunctor.Product.Default (Default)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
import Database.PostgreSQL.Simple
|
||||
|
||||
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
|
||||
|
||||
import Model
|
||||
|
||||
import Types
|
||||
|
||||
printSql :: Default Unpackspec a a => Select a -> IO ()
|
||||
printSql = putStrLn . fromMaybe "Empty query" . showSqlForPostgres
|
||||
|
||||
|
|
@ -34,3 +49,45 @@ initDB conn = do
|
|||
-- This is only a dummy function.
|
||||
-- TODO: Replace with proper translation function(s)!
|
||||
__ = 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!"
|
||||
|
|
|
|||
Loading…
Reference in a new issue