module Authenticator.Actions (
viewVault
, addSecret
, genSecret
, editSecret
, deleteSecret
) where
import Authenticator.Common
import Authenticator.Vault
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.Char
import Data.Dependent.Sum
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.Monoid
import Data.Singletons
import Data.String
import Data.Type.Conjunction
import Data.Witherable
import Lens.Micro
import Options.Applicative
import Prelude hiding (filter)
import System.Exit
import Text.Printf
import Text.Read (readMaybe)
import qualified Data.Text as T
import qualified System.Console.Haskeline as L
viewVault
:: Bool
-> Either Int (Maybe T.Text, Maybe T.Text)
-> Vault
-> IO ()
viewVault l filts vt = do
(n,found) <- runWriterT . flip execStateT 1 $ vaultSecrets (\(sc :: Secret m) ms -> do
i <- state $ \x -> (x :: Int, x + 1)
fmap (fromMaybe ms) . runMaybeT $ do
case filts of
Left n -> guard (i == n)
Right (fAcc, fIss) -> do
traverse_ (guard . (== secAccount sc)) fAcc
traverse_ (guard . (== secIssuer sc) . Just) fIss
lift . lift $ tell (Any True)
liftIO $ if l
then printf "(%d) %s\n" i (describeSecret sc) $> ms
else case sing @_ @m of
SHOTP -> ms <$
printf "(%d) %s: [ counter-based, use gen ]\n" i (describeSecret sc)
STOTP -> do
p <- totp sc
printf "(%d) %s: %s\n" i (describeSecret sc) p
return ms
) vt
printf "Searched %d total entries.\n" (n 1)
unless (getAny found) $ case filts of
Left i -> printf "ID %d not found!\n" i *> exitFailure
Right _ -> putStrLn "No matches found!"
addSecret :: Bool -> Bool -> Vault -> IO Vault
addSecret echoPass u vt = do
dsc <- if u
then do
q <- L.runInputT hlSettings $
fromMaybe "" <$> if echoPass
then L.getInputLine "URI Secret?: "
else L.getPassword (Just '*') "URI Secret?: "
case parseSecretURI q of
Left err -> do
putStrLn "Parse error:"
putStrLn err
exitFailure
Right d ->
return d
else mkSecret echoPass
putStrLn "Added succesfully!"
return $
vt & _Vault %~ (++ [dsc])
genSecret :: Int -> Vault -> IO (Maybe (String, Vault))
genSecret n vt = do
res <- runMaybeT . runWriterT . forOf (_Vault . ix (n 1)) vt $ \case
s :=> sc :&: ms ->
case s of
SHOTP -> do
let (p, ms') = hotp sc ms
out = printf "(%d) %s: %s\n" n (describeSecret sc) p
tell (First (Just out))
return $ s :=> sc :&: ms'
STOTP -> do
liftIO $ do
p <- totp sc
printf "(%d) %s: %s\n" n (describeSecret sc) p
empty
forM res $ \(r, changed) ->
case getFirst changed of
Just msg -> return (msg, r)
Nothing -> do
printf "No item with ID %d found.\n" n
exitFailure
editSecret :: Int -> Vault -> IO Vault
editSecret n vt = do
(vt', found) <- runWriterT . forOf (_Vault . ix (n 1)) vt $ \case
(s :=> sc :&: ms) -> do
sc' <- liftIO $ do
printf "Editing (%d) %s ...\n" n (describeSecret sc)
liftIO (mkSecretFrom sc)
tell (First (Just (describeSecret sc')))
return $ s :=> sc' :&: ms
case getFirst found of
Nothing -> do
printf "No item with ID %d found.\n" n
exitFailure
Just desc -> do
printf "%s edited successfuly!\n" desc
return vt'
deleteSecret :: Int -> Vault -> IO Vault
deleteSecret n vt = do
(vt', found) <- runWriterT . flip evalStateT 1 . forOf (_Vault . wither) vt $ \case
ds@(_ :=> sc :&: _) -> do
i <- state $ \x -> (x :: Int, x + 1)
if n == i
then do
lift $ tell (Any True)
a <- liftIO . L.runInputT hlSettings $
L.getInputChar (printf "Delete %s? y/[n]: " (describeSecret sc))
case toLower <$> a of
Just 'y' -> do
liftIO $ putStrLn "Deleted!"
return Nothing
_ -> return (Just ds)
else return (Just ds)
unless (getAny found) $ do
printf "No item with ID %d found.\n" n
exitFailure
return vt'
mkSecret :: Bool -> IO (DSum Sing (Secret :&: ModeState))
mkSecret echoPass = L.runInputT hlSettings $ do
a <- (mfilter (not . null) <$> L.getInputLine "Account?: ") >>= \case
Nothing -> liftIO $ putStrLn "Account required" >> exitFailure
Just r -> return r
i <- L.getInputLine "Issuer? (optional): "
k <- fromMaybe "" <$> if echoPass
then L.getInputLine "Secret?: "
else L.getPassword (Just '*') "Secret?: "
m <- L.getInputChar "[t]ime- or (c)ounter-based?: "
let i' = mfilter (not . null) i
k' = decodePad . T.pack $ k
s = Sec (T.pack a) (T.pack <$> i') HASHA1 6 <$> k'
case toLower <$> m of
Just 'c' -> do
n <- mfilter (not . null) <$> L.getInputLine "Initial counter? [0]: "
n' <- case n of
Nothing -> return 0
Just n' -> case readMaybe n' of
Just r -> return r
Nothing -> liftIO $ putStrLn "Invalid initial counter. Using 0." $> 0
case s of
Nothing -> liftIO $ do
printf "Invalid secret key: %s\n" k
exitFailure
Just s' -> return $ SHOTP :=> s' :&: HOTPState n'
_ -> do
case s of
Nothing -> liftIO $ do
printf "Invalid secret key: %s\n" k
exitFailure
Just s' -> return $ STOTP :=> s' :&: TOTPState
mkSecretFrom :: Secret m -> IO (Secret m)
mkSecretFrom sc = L.runInputT hlSettings $ do
a <- mfilter (not . null) <$> L.getInputLineWithInitial "Account?: " (T.unpack (secAccount sc), "")
i <- mfilter (not . null) <$> case secIssuer sc of
Nothing -> L.getInputLine "Issuer? (optional): "
Just si -> L.getInputLineWithInitial "Issuer? (optional): " (T.unpack si, "")
let a' = case a of
Nothing -> secAccount sc
Just r -> T.pack r
i' = case i of
Nothing -> secIssuer sc
Just r -> Just $ T.pack r
return $ sc { secAccount = a'
, secIssuer = i'
}