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 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
|
||||||
|
|
35
app/Main.hs
35
app/Main.hs
|
@ -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))
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
-- }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
57
src/Util.hs
57
src/Util.hs
|
@ -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!"
|
||||||
|
|
Loading…
Add table
Reference in a new issue