module Network.ScrapeChanges.Internal (
mailScrapeConfig
, otherScrapeConfig
, validateScrapeConfig
, validateCronSchedule
, readLatestHash
, saveHash
, executeCallbackConfig
, removeHash
, removeHashes
, hash'
, ScrapeInfoUrl
, MailFromAddr
, MailToAddr
, Hash
, loggerName
, httpExceptionHandler
) where
import Prelude hiding (filter)
import Data.Validation
import Data.List.NonEmpty hiding (head, tail)
import Data.Functor (($>))
import Control.Lens
import qualified Control.Exception as Exception
import qualified Network.URI as U
import qualified Data.Foldable as F
import Network.ScrapeChanges.Domain
import qualified Data.ByteString.Lens as ByteStringLens
import qualified Text.Email.Validate as EmailValidate
import qualified Data.Attoparsec.Text as AttoparsecText
import qualified System.Cron.Parser as CronParser
import Control.Monad (void)
import qualified Data.Hashable as Hashable
import Data.Hashable (Hashable)
import qualified System.Directory as Directory
import qualified Network.Mail.Mime as Mime
import System.FilePath ((</>))
import qualified System.IO.Error as IOError
import qualified System.Directory as Dir
import qualified System.FilePath as FilePath
import qualified System.IO.Strict as StrictIO
import qualified System.Log.Logger as Log
import qualified Data.Maybe as Maybe
import Network.HTTP.Client (HttpException)
import qualified Data.Text.Lazy as TextLazy
import qualified Data.Text as TextStrict
import qualified Data.Text.Lens as TextStrictLens
type ScrapeInfoUrl = String
type MailFromAddr = MailAddr
type MailToAddr = MailAddr
mailScrapeConfig :: ScrapeInfoUrl -> MailFromAddr -> NonEmpty MailToAddr -> ScrapeConfig
mailScrapeConfig siu mfa mtads = ScrapeConfig {
_scrapeInfoUrl = siu
, _scrapeInfoCallbackConfig = MailConfig defaultMail
} where defaultMail :: Mail
defaultMail = Mail {
_mailFrom = mfa
, _mailTo = mtads
, _mailSubject = ""
, _mailBody = ""
}
otherScrapeConfig :: ScrapeInfoUrl -> (Text -> IO ()) -> ScrapeConfig
otherScrapeConfig url f = ScrapeConfig {
_scrapeInfoUrl = url
, _scrapeInfoCallbackConfig = OtherConfig f
}
validateScrapeConfig :: ScrapeConfig -> ScrapeValidation ScrapeConfig
validateScrapeConfig si =
let toUnit = void
urlValidation = validateUrl $ si ^. scrapeInfoUrl
callbackValidation = validateCallbackConfig $ si ^. scrapeInfoCallbackConfig
in const si <$> F.sequenceA_ [toUnit urlValidation, toUnit callbackValidation]
validateCallbackConfig :: CallbackConfig -> ScrapeValidation CallbackConfig
validateCallbackConfig (MailConfig m) = MailConfig <$> validateMailConfig m
validateCallbackConfig c@(OtherConfig _) = pure c
validateCronSchedule :: CronScheduleString -> ScrapeValidation CronScheduleString
validateCronSchedule c =
let mapFailure = _Failure %~ \s -> [CronScheduleInvalid s]
setSuccess = _Success .~ c
either' = AttoparsecText.parseOnly CronParser.cronSchedule (TextStrict.pack c)
mappedEither' = either' & mapFailure
& setSuccess
in mappedEither' ^. _AccValidation
type Hash = String
hashPath :: Hash -> IO FilePath
hashPath hash'' = let fileName = hash'' ++ ".hash"
buildHashPath p = p </> fileName
in buildHashPath <$> hashPathDir
hashPathDir :: IO FilePath
hashPathDir = Directory.getAppUserDataDirectory "scrape-changes"
readLatestHash :: (Hashable t) => t -> IO (Maybe Hash)
readLatestHash t = let readLatestHash' = hashPath (hash' t) >>= StrictIO.readFile
readLatestHashMaybe = Just <$> readLatestHash'
in readLatestHashMaybe `IOError.catchIOError` (\e -> if IOError.isDoesNotExistError e then pure Nothing else ioError e)
hash' :: Hashable t => t -> String
hash' = show . Hashable.hash
removeHash :: (Hashable t) => t -> IO ()
removeHash t = ((hashPath . hash' $ t) >>= Directory.removeFile) `Exception.catch` catchException
where catchException e | IOError.isDoesNotExistError e = return ()
| otherwise = Exception.throwIO e
removeHashes :: IO ()
removeHashes = let removeAction = hashPathDir >>= Directory.removeDirectory
in Exception.catch removeAction catchAll
where catchAll :: Exception.SomeException -> IO ()
catchAll = const . return $ ()
executeCallbackConfig :: ScrapeConfig -> Text -> IO ()
executeCallbackConfig (ScrapeConfig url (MailConfig m)) result =
let m' = m & set mailBody result
& set mailSubject (TextLazy.pack $ "Changes from " ++ url)
mimeMail = toMimeMail m'
debugLog = Log.debugM loggerName $ "Mail body: " ++ show m'
in debugLog *> Mime.renderSendMail mimeMail
executeCallbackConfig (ScrapeConfig _ (OtherConfig f)) result = f result $> ()
loggerName :: String
loggerName = "Network.ScrapeChanges"
validateMailConfig :: Mail -> ScrapeValidation Mail
validateMailConfig m =
let mailAddrs t = fromList $ m ^.. (t . traverse . mailAddr)
isInvalidMailAddr = (not . EmailValidate.isValid . (^. ByteStringLens.packedChars))
mailFromAddr = m ^. mailFrom . mailAddr
invalidMailFromAddrs = MailConfigInvalidMailFromAddr <$> [mailFromAddr | isInvalidMailAddr mailFromAddr]
mailToAddrs = mailAddrs mailTo
invalidMailToAddrs = MailConfigInvalidMailToAddr <$> (isInvalidMailAddr `filter` mailToAddrs)
ok = pure m
in const m <$> F.sequenceA_ [
if null invalidMailFromAddrs then ok else AccFailure invalidMailFromAddrs
, if null invalidMailToAddrs then ok else AccFailure invalidMailToAddrs
]
validateUrl :: String -> ScrapeValidation String
validateUrl s = let uriMaybe = U.parseAbsoluteURI s
isAbsoluteUrl = U.isAbsoluteURI s
protocolMaybe = U.uriScheme <$> uriMaybe
isHttp = (=="http:") `F.all` protocolMaybe
ok = pure s
in const s <$> F.sequenceA_ [
if isAbsoluteUrl then ok else AccFailure [UrlNotAbsolute]
, if isHttp then ok else AccFailure [UrlProtocolInvalid]
]
saveHash :: (Hashable t) => t -> Hash -> IO ()
saveHash t hash'' = let hashOfT = hash' t
hashPathForT = hashPath hashOfT >>= createParentDirs
in hashPathForT >>= flip writeFile hash''
toMimeMail :: Mail -> Mime.Mail
toMimeMail m = let toMimeAddress' ms = toList $ toMimeAddress <$> ms
mailToMime = toMimeAddress' $ m ^. mailTo
mailFromMime = toMimeAddress $ m ^. mailFrom
mailSubjectMime = m ^. mailSubject
mailBodyMime = m ^. mailBody
mimeMail = Mime.simpleMail' (head mailToMime) mailFromMime (TextLazy.toStrict mailSubjectMime) mailBodyMime
in mimeMail { Mime.mailTo = Mime.mailTo mimeMail ++ tail mailToMime }
toMimeAddress :: MailAddr -> Mime.Address
toMimeAddress a = Mime.Address {
Mime.addressName = a ^? mailAddrName . _Just . to TextLazy.toStrict
, Mime.addressEmail = a ^. mailAddr . TextStrictLens.packed
}
createParentDirs :: FilePath -> IO FilePath
createParentDirs fp = let fpDir = FilePath.takeDirectory fp
in Dir.createDirectoryIfMissing True fpDir *> pure fp
httpExceptionHandler :: ScrapeConfig -> HttpException -> IO t
httpExceptionHandler sc e = let maybeMail = sc ^? scrapeInfoCallbackConfig . _MailConfig
url = sc ^. scrapeInfoUrl
maybeMailAction = Maybe.fromMaybe (pure ()) (sendMail url <$> maybeMail)
in F.sequenceA_ [Log.errorM loggerName (show e), maybeMailAction] *> Exception.throw e
where sendMail :: Url -> Mail -> IO ()
sendMail url m = let m' = m & set mailBody (TextLazy.pack $ show e)
& set mailSubject (TextLazy.pack $ "Http error while requesting " ++ url)
mimeMail = toMimeMail m'
in Mime.renderSendMail mimeMail