module Gamgee.Effects.SecretInput
    ( -- * Effect
      SecretInput(..)

      -- * Actions
    , secretInput

      -- * Interpretations
    , runSecretInputIO
    ) where

import           Control.Exception.Safe (bracket_)
import           Polysemy               (Embed, Member, Sem)
import qualified Polysemy               as P
import           Relude
import qualified System.IO              as IO


----------------------------------------------------------------------------------------------------
-- Effect
----------------------------------------------------------------------------------------------------

-- | An effect that provides input to the application. Intended to be
-- used in contexts where the input is a secret such as
-- passwords. Interpretations may chose to "protect" the input
-- appropriately. For example, an IO interpretation may chose not to
-- echo the input to the console.
data SecretInput i m a where
  -- | Retrieve a secret input
  SecretInput :: Text              -- ^ A prompt
              -> SecretInput i m i

P.makeSem ''SecretInput


----------------------------------------------------------------------------------------------------
-- Interpretations
----------------------------------------------------------------------------------------------------

runSecretInputIO :: (Member (Embed IO) r) => Sem (SecretInput Text : r) a -> Sem r a
runSecretInputIO :: Sem (SecretInput Text : r) a -> Sem r a
runSecretInputIO = (forall x (rInitial :: EffectRow).
 SecretInput Text (Sem rInitial) x -> Sem r x)
-> Sem (SecretInput Text : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (rInitial :: EffectRow).
  SecretInput Text (Sem rInitial) x -> Sem r x)
 -> Sem (SecretInput Text : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    SecretInput Text (Sem rInitial) x -> Sem r x)
-> Sem (SecretInput Text : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  SecretInput prompt -> IO Text -> Sem r Text
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Text -> Sem r Text) -> IO Text -> Sem r Text
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText Text
prompt
    Handle -> IO ()
IO.hFlush Handle
stdout
    Text
i <- IO Text -> IO Text
forall a. IO a -> IO a
withoutEcho IO Text
forall (m :: * -> *). MonadIO m => m Text
getLine
    Char -> IO ()
IO.putChar Char
'\n'
    return Text
i

    where
      withoutEcho :: IO a -> IO a
      withoutEcho :: IO a -> IO a
withoutEcho IO a
f = do
        Bool
old <- Handle -> IO Bool
IO.hGetEcho Handle
stdin
        IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a b c. MonadMask m => m a -> m b -> m c -> m c
bracket_ (Handle -> Bool -> IO ()
IO.hSetEcho Handle
stdin Bool
False) (Handle -> Bool -> IO ()
IO.hSetEcho Handle
stdin Bool
old) IO a
f