diff --git a/app/AppTypes/Configuration.hs b/app/AppTypes/Configuration.hs index 9368b1b..0506f51 100644 --- a/app/AppTypes/Configuration.hs +++ b/app/AppTypes/Configuration.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 30431b5..883acb7 100644 --- a/app/Main.hs +++ b/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)) diff --git a/config.yaml b/config.yaml index 62e3be6..66f8b30 100644 --- a/config.yaml +++ b/config.yaml @@ -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" diff --git a/mateamt.cabal b/mateamt.cabal index c25e6cf..7bcb547 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/src/Control/Meta.hs b/src/Control/Meta.hs index 8d453dd..fb70c5f 100644 --- a/src/Control/Meta.hs +++ b/src/Control/Meta.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index 50890fc..a8663b2 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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" + -- } diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index d9f47e3..ec48ab6 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -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 diff --git a/src/Model/Product.hs b/src/Model/Product.hs index eea9159..173e8df 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -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 } diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 910fe72..aebb5c1 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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) diff --git a/src/Types/Product.hs b/src/Types/Product.hs index 202aaae..d7f1631 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -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 diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs index 30ca565..49d9d87 100644 --- a/src/Types/Reader.hs +++ b/src/Types/Reader.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index e21735a..913cc9b 100644 --- a/src/Util.hs +++ b/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!"