module Imm.Boot (imm) where
import qualified Imm.Core as Core
import Imm.Database.FeedTable as Database
import Imm.Database as Database
import Imm.Dyre as Dyre
import Imm.Feed
import Imm.HTTP as HTTP
import Imm.Hooks
import Imm.Logger as Logger
import Imm.Options as Options hiding(logLevel)
import Imm.Prelude
import Control.Comonad.Cofree
import Control.Monad.Trans.Free
import System.IO (hFlush)
imm :: (a -> CoHttpClientF IO a, a)
-> (b -> CoDatabaseF' IO b, b)
-> (c -> CoLoggerF IO c, c)
-> (d -> CoHooksF IO d, d)
-> IO ()
imm coHttpClient coDatabase coLogger coHooks = void $ do
options <- parseOptions
Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, coiter next start)
where (next, start) = mkCoImm coHttpClient coDatabase coLogger coHooks
realMain :: (MonadIO m, PairingM (CoImmF m) ImmF m, MonadCatch m)
=> (Command, LogLevel, Cofree (CoImmF m) a) -> m ()
realMain (command, logLevel, interpreter) = void $ interpret (\_ b -> return b) interpreter $ do
setLogLevel logLevel
logDebug $ "Executing: " <> show (pretty command)
handleAll (logError . fromString . displayException) $ case command of
Check t -> Core.check =<< resolveTarget ByPassConfirmation t
Import -> Core.importOPML
Read t -> mapM_ Database.markAsRead =<< resolveTarget AskConfirmation t
Run t -> Core.run =<< resolveTarget ByPassConfirmation t
Show t -> Core.showFeed =<< resolveTarget ByPassConfirmation t
ShowVersion -> Core.printVersions
Subscribe u c -> Core.subscribe u c
Unread t -> mapM_ Database.markAsUnread =<< resolveTarget AskConfirmation t
Unsubscribe t -> Database.deleteList FeedTable =<< resolveTarget AskConfirmation t
_ -> return ()
Database.commit FeedTable
return ()
type CoImmF m = CoHttpClientF m :*: CoDatabaseF' m :*: CoLoggerF m :*: CoHooksF m
type ImmF = HttpClientF :+: DatabaseF' :+: LoggerF :+: HooksF
mkCoImm :: (Functor m)
=> (a -> CoHttpClientF m a, a) -> (b -> CoDatabaseF' m b, b) -> (c -> CoLoggerF m c, c) -> (d -> CoHooksF m d, d)
-> ((a ::: b ::: c ::: d) -> CoImmF m (a ::: b ::: c ::: d), a ::: b ::: c ::: d)
mkCoImm (coHttpClient, a) (coDatabase, b) (coLogger, c) (coHooks, d) =
(coHttpClient *:* coDatabase *:* coLogger *:* coHooks, a >: b >: c >: d)
data SafeGuard = AskConfirmation | ByPassConfirmation
deriving(Eq, Show)
data InterruptedException = InterruptedException deriving(Eq, Show)
instance Exception InterruptedException where
displayException _ = "Process interrupted"
promptConfirm :: (MonadIO m, MonadThrow m) => Text -> m ()
promptConfirm s = do
hPut stdout $ s <> " Confirm [Y/n] "
io $ hFlush stdout
x <- getLine
when (x /= ("" :: Text) && x /= ("Y" :: Text)) $ throwM InterruptedException
resolveTarget :: (MonadIO m, MonadThrow m, Functor f, MonadFree f m, DatabaseF' :<: f, LoggerF :<: f)
=> SafeGuard -> Maybe Core.FeedRef -> m [FeedID]
resolveTarget s Nothing = do
result <- keys <$> Database.fetchAll FeedTable
when (s == AskConfirmation) . promptConfirm $ "This will affect " <> show (length result) <> " feeds."
return result
resolveTarget _ (Just (FeedRef (Left i))) = do
result <- fst . (!! i) . mapToList <$> Database.fetchAll FeedTable
return $ singleton result
resolveTarget _ (Just (FeedRef (Right uri))) = return [FeedID uri]