{-# 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 $ execute_ conn initSettings 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" }