mateamt/src/Util.hs

196 lines
5.4 KiB
Haskell
Raw Permalink Normal View History

{-# LANGUAGE FlexibleContexts #-}
2021-07-12 11:29:40 +00:00
{-# LANGUAGE OverloadedStrings #-}
2022-02-20 20:48:16 +00:00
{-# LANGUAGE RecordWildCards #-}
module Util where
import Control.Concurrent.STM (TQueue, tryReadTQueue, atomically, writeTQueue)
import Control.Concurrent (threadDelay)
import Control.Monad.Extra (whileM)
2022-04-15 18:53:37 +00:00
import Servant
import Opaleye
2021-07-12 11:29:40 +00:00
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Char8 (hPutStrLn)
2021-07-12 11:29:40 +00:00
2022-04-15 19:06:18 +00:00
import Data.Maybe (fromMaybe, fromJust)
import Data.Profunctor.Product.Default (Default)
2022-04-15 18:51:22 +00:00
import Data.String (fromString)
2021-07-12 11:29:40 +00:00
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
2021-02-01 01:25:08 +00:00
import Database.PostgreSQL.Simple
import Control.Monad (void, filterM, forever)
2021-07-12 11:29:40 +00:00
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Network.Mail.Mime
import System.Directory (doesFileExist)
import System.IO (stderr)
2021-02-01 01:25:08 +00:00
-- internal imports
import Model
2021-07-12 11:29:40 +00:00
import Types
2022-04-15 18:52:32 +00:00
-- | This is the internal function to check a users authorization to do certain
-- actions
checkCapability
:: Int -- ^ User Id to check
-> (Role -> Bool) -- ^ Predicate to check
-> MateHandler Bool -- ^ Result
checkCapability uid accessRule = do
conn <- asks rsConnection
assocs <- selectUserAssociations uid conn
let rids = map roleAssociationRole assocs
roles <- selectRoleList rids conn
return $ any accessRule roles
notImplemented :: MateHandler a
notImplemented = throwError $ err501
{ errBody = "Function has not yet been implemented!"
}
2022-02-20 20:48:16 +00:00
printSql :: Default Unpackspec a a => Select a -> IO ()
2022-02-20 20:03:05 +00:00
printSql = putStrLn . fromMaybe "Empty query" . showSql
2021-02-01 01:25:08 +00:00
initDB :: Connection -> IO ()
initDB conn = do
2022-02-20 20:03:05 +00:00
void $ execute_ conn initAvatar
void $ execute_ conn initUser
void $ execute_ conn initProduct
void $ execute_ conn initToken
void $ execute_ conn initAuthData
void $ execute_ conn initAmount
void $ execute_ conn initJournal
void $ execute_ conn initRole
void $ execute_ conn initUserToRole
2023-07-07 22:16:05 +00:00
void $ execute_ conn initSettings
2021-02-01 01:25:08 +00:00
void $ runInsertInitialRoles conn
2021-06-24 04:33:05 +00:00
-- This is only a dummy function.
-- TODO: Replace with proper translation function(s)!
__ = id
2021-07-12 11:29:40 +00:00
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)
2021-10-16 15:50:28 +00:00
email
2021-07-12 11:29:40 +00:00
]
, 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 ()
2021-07-14 01:08:58 +00:00
sendAdminNotification
:: T.Text -- The mail subject
-> T.Text -- The mail body
-> MateHandler ()
2022-02-20 20:48:16 +00:00
sendAdminNotification subject message = do
2022-04-15 18:52:46 +00:00
conn <- asks rsConnection
allUsers <- userDetailsSelectAll conn
2022-04-15 19:06:18 +00:00
admins <- filterM
((`checkCapability` roleCanManageSettings) . userDetailsId)
2022-02-20 20:48:16 +00:00
allUsers
mapM_
2022-04-15 19:06:18 +00:00
(\ UserDetails{..} ->
2022-02-20 20:48:16 +00:00
let mail = Mail
{ mailFrom = Address Nothing "noreply"
, mailTo =
[ Address
(Just userDetailsIdent)
2022-04-15 19:06:18 +00:00
(fromJust userDetailsEmail)
2022-02-20 20:48:16 +00:00
]
, mailCc = []
2022-07-31 00:36:15 +00:00
, mailBcc = []
2022-04-15 18:52:46 +00:00
, mailHeaders = [("Subject", subject)]
, mailParts =
2022-02-20 20:48:16 +00:00
[[ Part
{ partType = "text/plain; charset=utf8"
, partEncoding = None
, partDisposition = DefaultDisposition
, partHeaders = []
2022-04-15 19:06:18 +00:00
, partContent = PartContent (fromString $ T.unpack message)
2022-02-20 20:48:16 +00:00
}
]]
}
in
sendNotification mail
)
2022-04-15 18:52:46 +00:00
admins
2021-07-14 01:08:58 +00:00
2021-10-16 15:50:28 +00:00
sendNotification :: Mail -> MateHandler ()
2021-07-12 11:29:40 +00:00
sendNotification mail = do
mailQueue <- asks rsMailQueue
void $ liftIO $ atomically $ writeTQueue mailQueue mail
engageCourier :: TQueue Mail -> FilePath -> IO ()
engageCourier mailQueue sendmailPath = forever $ do
threadDelay (10 ^ (6 :: Int))
whileM $ do
mEmail <- atomically $ tryReadTQueue mailQueue
case mEmail of
Just email -> do
sendEmail email sendmailPath
return True
Nothing ->
return False
sendEmail :: Mail -> FilePath -> IO ()
sendEmail email sendmailPath = do
existence <- doesFileExist sendmailPath
if existence
then
renderSendMailCustom sendmailPath [] email
else
hPutStrLn stderr "Error: sending notification failed: Sendmail not present!"
2022-07-17 19:28:22 +00:00
2022-07-30 23:43:46 +00:00
-- | throws a HTTP 401 error in case no auth token was provided when needed
throwMissingAuth :: MateHandler a
throwMissingAuth = throwError $ err401
{ errBody = "No authentication present"
}
-- | throws a HHTP 401 error in case the provided token does not match the required authentication
-- Method (e.g.: 'PrimaryPass')
throwWrongAuth :: MateHandler a
throwWrongAuth = throwError $ err401
{ errBody = "Wrong authentication present"
}
-- | throws a HTTP 401 error in case the user Role does not have the required capabilities.
throwUnauthAccess :: MateHandler a
throwUnauthAccess = throwError $ err401
{ errBody = "Unauthorized Access"
2022-07-17 19:28:22 +00:00
}