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 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

View file

@ -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))

View file

@ -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"

View file

@ -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

View file

@ -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

View file

@ -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"
-- }

View file

@ -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

View file

@ -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
}

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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!"