mateamt/src/Util.hs

195 lines
5.4 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Util where
import Control.Concurrent.STM (TQueue, tryReadTQueue, atomically, writeTQueue)
import Control.Concurrent (threadDelay)
import Control.Monad.Extra (whileM)
import Servant
import Opaleye
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Maybe (fromMaybe, fromJust)
import Data.Profunctor.Product.Default (Default)
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Database.PostgreSQL.Simple
import Control.Monad (void, filterM, forever)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Network.Mail.Mime
import System.Directory (doesFileExist)
import System.IO (stderr)
-- internal imports
import Model
import Types
-- | 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!"
}
printSql :: Default Unpackspec a a => Select a -> IO ()
printSql = putStrLn . fromMaybe "Empty query" . showSql
initDB :: Connection -> IO ()
initDB conn = do
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
void $ runInsertInitialRoles conn
-- 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 ()
sendAdminNotification
:: T.Text -- The mail subject
-> T.Text -- The mail body
-> MateHandler ()
sendAdminNotification subject message = do
conn <- asks rsConnection
allUsers <- userDetailsSelectAll conn
admins <- filterM
((`checkCapability` roleCanManageSettings) . userDetailsId)
allUsers
mapM_
(\ UserDetails{..} ->
let mail = Mail
{ mailFrom = Address Nothing "noreply"
, mailTo =
[ Address
(Just userDetailsIdent)
(fromJust userDetailsEmail)
]
, mailCc = []
, mailBcc = []
, mailHeaders = [("Subject", subject)]
, mailParts =
[[ Part
{ partType = "text/plain; charset=utf8"
, partEncoding = None
, partDisposition = DefaultDisposition
, partHeaders = []
, partContent = PartContent (fromString $ T.unpack message)
}
]]
}
in
sendNotification mail
)
admins
sendNotification :: Mail -> MateHandler ()
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!"
-- | 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"
}