{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnicodeSyntax #-}

module Imm.Callback (Callback (..), CallbackMessage (..), runCallback) where

-- {{{ Imports
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Dhall hiding (maybe)
import Imm.Feed
import Imm.Logger as Logger
import Imm.Pretty
import System.Exit
import System.Process.Typed

-- }}}

-- | External program run for each feed element.
--
-- Data is passed to that program through standard input (@stdin@).
data Callback = Callback
  { Callback -> [Char]
_executable ∷ FilePath
  , Callback -> [Text]
_arguments ∷ [Text]
  }
  deriving (Callback -> Callback -> Bool
(Callback -> Callback -> Bool)
-> (Callback -> Callback -> Bool) -> Eq Callback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Callback -> Callback -> Bool
== :: Callback -> Callback -> Bool
$c/= :: Callback -> Callback -> Bool
/= :: Callback -> Callback -> Bool
Eq, (forall x. Callback -> Rep Callback x)
-> (forall x. Rep Callback x -> Callback) -> Generic Callback
forall x. Rep Callback x -> Callback
forall x. Callback -> Rep Callback x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Callback -> Rep Callback x
from :: forall x. Callback -> Rep Callback x
$cto :: forall x. Rep Callback x -> Callback
to :: forall x. Rep Callback x -> Callback
Generic, Eq Callback
Eq Callback =>
(Callback -> Callback -> Ordering)
-> (Callback -> Callback -> Bool)
-> (Callback -> Callback -> Bool)
-> (Callback -> Callback -> Bool)
-> (Callback -> Callback -> Bool)
-> (Callback -> Callback -> Callback)
-> (Callback -> Callback -> Callback)
-> Ord Callback
Callback -> Callback -> Bool
Callback -> Callback -> Ordering
Callback -> Callback -> Callback
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Callback -> Callback -> Ordering
compare :: Callback -> Callback -> Ordering
$c< :: Callback -> Callback -> Bool
< :: Callback -> Callback -> Bool
$c<= :: Callback -> Callback -> Bool
<= :: Callback -> Callback -> Bool
$c> :: Callback -> Callback -> Bool
> :: Callback -> Callback -> Bool
$c>= :: Callback -> Callback -> Bool
>= :: Callback -> Callback -> Bool
$cmax :: Callback -> Callback -> Callback
max :: Callback -> Callback -> Callback
$cmin :: Callback -> Callback -> Callback
min :: Callback -> Callback -> Callback
Ord, ReadPrec [Callback]
ReadPrec Callback
Int -> ReadS Callback
ReadS [Callback]
(Int -> ReadS Callback)
-> ReadS [Callback]
-> ReadPrec Callback
-> ReadPrec [Callback]
-> Read Callback
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Callback
readsPrec :: Int -> ReadS Callback
$creadList :: ReadS [Callback]
readList :: ReadS [Callback]
$creadPrec :: ReadPrec Callback
readPrec :: ReadPrec Callback
$creadListPrec :: ReadPrec [Callback]
readListPrec :: ReadPrec [Callback]
Read, Int -> Callback -> ShowS
[Callback] -> ShowS
Callback -> [Char]
(Int -> Callback -> ShowS)
-> (Callback -> [Char]) -> ([Callback] -> ShowS) -> Show Callback
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Callback -> ShowS
showsPrec :: Int -> Callback -> ShowS
$cshow :: Callback -> [Char]
show :: Callback -> [Char]
$cshowList :: [Callback] -> ShowS
showList :: [Callback] -> ShowS
Show)

instance FromDhall Callback

instance Pretty Callback where
  pretty :: forall ann. Callback -> Doc ann
pretty (Callback [Char]
executable [Text]
arguments) = [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
executable Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> [Text] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
arguments)

-- | Data structure passed to the external program, through JSON format.
--
-- The data schema is described in file @schema/imm.json@, provided with this library.
data CallbackMessage = CallbackMessage
  { CallbackMessage -> FeedLocation
_callbackFeedLocation ∷ FeedLocation
  , CallbackMessage -> FeedDefinition
_callbackFeedDefinition ∷ FeedDefinition
  , CallbackMessage -> FeedItem
_callbackFeedItem ∷ FeedItem
  }
  deriving (CallbackMessage -> CallbackMessage -> Bool
(CallbackMessage -> CallbackMessage -> Bool)
-> (CallbackMessage -> CallbackMessage -> Bool)
-> Eq CallbackMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallbackMessage -> CallbackMessage -> Bool
== :: CallbackMessage -> CallbackMessage -> Bool
$c/= :: CallbackMessage -> CallbackMessage -> Bool
/= :: CallbackMessage -> CallbackMessage -> Bool
Eq, (forall x. CallbackMessage -> Rep CallbackMessage x)
-> (forall x. Rep CallbackMessage x -> CallbackMessage)
-> Generic CallbackMessage
forall x. Rep CallbackMessage x -> CallbackMessage
forall x. CallbackMessage -> Rep CallbackMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CallbackMessage -> Rep CallbackMessage x
from :: forall x. CallbackMessage -> Rep CallbackMessage x
$cto :: forall x. Rep CallbackMessage x -> CallbackMessage
to :: forall x. Rep CallbackMessage x -> CallbackMessage
Generic, Eq CallbackMessage
Eq CallbackMessage =>
(CallbackMessage -> CallbackMessage -> Ordering)
-> (CallbackMessage -> CallbackMessage -> Bool)
-> (CallbackMessage -> CallbackMessage -> Bool)
-> (CallbackMessage -> CallbackMessage -> Bool)
-> (CallbackMessage -> CallbackMessage -> Bool)
-> (CallbackMessage -> CallbackMessage -> CallbackMessage)
-> (CallbackMessage -> CallbackMessage -> CallbackMessage)
-> Ord CallbackMessage
CallbackMessage -> CallbackMessage -> Bool
CallbackMessage -> CallbackMessage -> Ordering
CallbackMessage -> CallbackMessage -> CallbackMessage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CallbackMessage -> CallbackMessage -> Ordering
compare :: CallbackMessage -> CallbackMessage -> Ordering
$c< :: CallbackMessage -> CallbackMessage -> Bool
< :: CallbackMessage -> CallbackMessage -> Bool
$c<= :: CallbackMessage -> CallbackMessage -> Bool
<= :: CallbackMessage -> CallbackMessage -> Bool
$c> :: CallbackMessage -> CallbackMessage -> Bool
> :: CallbackMessage -> CallbackMessage -> Bool
$c>= :: CallbackMessage -> CallbackMessage -> Bool
>= :: CallbackMessage -> CallbackMessage -> Bool
$cmax :: CallbackMessage -> CallbackMessage -> CallbackMessage
max :: CallbackMessage -> CallbackMessage -> CallbackMessage
$cmin :: CallbackMessage -> CallbackMessage -> CallbackMessage
min :: CallbackMessage -> CallbackMessage -> CallbackMessage
Ord, Int -> CallbackMessage -> ShowS
[CallbackMessage] -> ShowS
CallbackMessage -> [Char]
(Int -> CallbackMessage -> ShowS)
-> (CallbackMessage -> [Char])
-> ([CallbackMessage] -> ShowS)
-> Show CallbackMessage
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallbackMessage -> ShowS
showsPrec :: Int -> CallbackMessage -> ShowS
$cshow :: CallbackMessage -> [Char]
show :: CallbackMessage -> [Char]
$cshowList :: [CallbackMessage] -> ShowS
showList :: [CallbackMessage] -> ShowS
Show, Typeable)

customOptions ∷ Options
customOptions :: Options
customOptions =
  Options
defaultOptions
    { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_callback")
    , omitNothingFields = True
    }

instance ToJSON CallbackMessage where
  toJSON :: CallbackMessage -> Value
toJSON = Options -> CallbackMessage -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
customOptions
  toEncoding :: CallbackMessage -> Encoding
toEncoding = Options -> CallbackMessage -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
customOptions

instance FromJSON CallbackMessage where
  parseJSON :: Value -> Parser CallbackMessage
parseJSON = Options -> Value -> Parser CallbackMessage
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
customOptions

instance Pretty (PrettyShort CallbackMessage) where
  pretty :: forall ann. PrettyShort CallbackMessage -> Doc ann
pretty (PrettyShort (CallbackMessage FeedLocation
location FeedDefinition
feed FeedItem
item)) = FeedLocation -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. FeedLocation -> Doc ann
pretty FeedLocation
location Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"/" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FeedDefinition -> Doc ann
forall a b. Pretty (PrettyName a) => a -> Doc b
prettyName FeedDefinition
feed Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"/" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FeedItem -> Text
_itemTitle FeedItem
item)

runCallback
  ∷ MonadIO m
  ⇒ Logger.Handle m
  → Callback
  → CallbackMessage
  → m (Either (Callback, Int, LByteString, LByteString) (Callback, LByteString, LByteString))
runCallback :: forall (m :: * -> *).
MonadIO m =>
Handle m
-> Callback
-> CallbackMessage
-> m (Either
        (Callback, Int, LByteString, LByteString)
        (Callback, LByteString, LByteString))
runCallback Handle m
logger callback :: Callback
callback@(Callback [Char]
executable [Text]
arguments) CallbackMessage
message = do
  Handle m -> LogLevel -> Doc AnsiStyle -> m ()
forall (m :: * -> *). Handle m -> LogLevel -> Doc AnsiStyle -> m ()
log Handle m
logger LogLevel
Info (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Running" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
cyan ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
executable) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"on" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CallbackMessage -> Doc AnsiStyle
forall a b. Pretty (PrettyShort a) => a -> Doc b
prettyShort CallbackMessage
message
  Handle m -> LogLevel -> Doc AnsiStyle -> m ()
forall (m :: * -> *). Handle m -> LogLevel -> Doc AnsiStyle -> m ()
log Handle m
logger LogLevel
Debug (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Callback message:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @Text (LByteString -> Text) -> LByteString -> Text
forall a b. (a -> b) -> a -> b
$ CallbackMessage -> LByteString
forall a. ToJSON a => a -> LByteString
encodePretty CallbackMessage
message)

  let processInput :: StreamSpec 'STInput ()
processInput = LByteString -> StreamSpec 'STInput ()
byteStringInput (LByteString -> StreamSpec 'STInput ())
-> LByteString -> StreamSpec 'STInput ()
forall a b. (a -> b) -> a -> b
$ CallbackMessage -> LByteString
forall a. ToJSON a => a -> LByteString
encode CallbackMessage
message
      processConfig :: ProcessConfig () () ()
processConfig = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
executable (Text -> [Char]
forall a. ToString a => a -> [Char]
toString (Text -> [Char]) -> [Text] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
arguments) ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
processInput
  (ExitCode
exitCode, LByteString
output, LByteString
errors) ← ProcessConfig () () () -> m (ExitCode, LByteString, LByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, LByteString, LByteString)
readProcess ProcessConfig () () ()
processConfig

  case ExitCode
exitCode of
    ExitCode
ExitSuccess → Either
  (Callback, Int, LByteString, LByteString)
  (Callback, LByteString, LByteString)
-> m (Either
        (Callback, Int, LByteString, LByteString)
        (Callback, LByteString, LByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Callback, Int, LByteString, LByteString)
   (Callback, LByteString, LByteString)
 -> m (Either
         (Callback, Int, LByteString, LByteString)
         (Callback, LByteString, LByteString)))
-> Either
     (Callback, Int, LByteString, LByteString)
     (Callback, LByteString, LByteString)
-> m (Either
        (Callback, Int, LByteString, LByteString)
        (Callback, LByteString, LByteString))
forall a b. (a -> b) -> a -> b
$ (Callback, LByteString, LByteString)
-> Either
     (Callback, Int, LByteString, LByteString)
     (Callback, LByteString, LByteString)
forall a b. b -> Either a b
Right (Callback
callback, LByteString
output, LByteString
errors)
    ExitFailure Int
i → Either
  (Callback, Int, LByteString, LByteString)
  (Callback, LByteString, LByteString)
-> m (Either
        (Callback, Int, LByteString, LByteString)
        (Callback, LByteString, LByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Callback, Int, LByteString, LByteString)
   (Callback, LByteString, LByteString)
 -> m (Either
         (Callback, Int, LByteString, LByteString)
         (Callback, LByteString, LByteString)))
-> Either
     (Callback, Int, LByteString, LByteString)
     (Callback, LByteString, LByteString)
-> m (Either
        (Callback, Int, LByteString, LByteString)
        (Callback, LByteString, LByteString))
forall a b. (a -> b) -> a -> b
$ (Callback, Int, LByteString, LByteString)
-> Either
     (Callback, Int, LByteString, LByteString)
     (Callback, LByteString, LByteString)
forall a b. a -> Either a b
Left (Callback
callback, Int
i, LByteString
output, LByteString
errors)