{-# LANGUAGE OverloadedStrings #-}
module Aura.Utils
(
Pattern(..)
, replaceByPatt, searchLines
, strictText
, urlContents
, csi, cursorUpLineCode, hideCursor, showCursor, raiseCursorBy
, getTrueUser, getEditor, getLocale
, hasRootPriv, isTrueRoot
, chown
, ifFile
, putStrLnA
, colourCheck
, entrify
, optionalPrompt
, getSelection
, maybe'
) where
import Aura.Colour
import Aura.Languages (whitespace, yesNoMessage, yesPattern)
import Aura.Settings
import Aura.Types (Environment, Language, User(..))
import BasePrelude hiding (Version, (<+>))
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode)
import System.IO (hFlush, stdout)
import System.Path (Absolute, Path, toFilePath)
import System.Path.IO (doesFileExist)
import System.Process.Typed (proc, runProcess)
data Pattern = Pattern { _pattern :: T.Text, _target :: T.Text }
replaceByPatt :: [Pattern] -> T.Text -> T.Text
replaceByPatt [] l = l
replaceByPatt (Pattern p t : ps) l = case T.breakOn p l of
(_, "") -> replaceByPatt ps l
(cs, rest) -> replaceByPatt ps (cs <> t <> T.drop (T.length p) rest)
searchLines :: T.Text -> [T.Text] -> [T.Text]
searchLines pat = filter (T.isInfixOf pat)
strictText :: BL.ByteString -> T.Text
strictText = TL.toStrict . TL.decodeUtf8With lenientDecode
getSelection :: Foldable f => (a -> T.Text) -> f a -> IO a
getSelection f choiceLabels = do
let quantity = length choiceLabels
valids = show <$> [1..quantity]
pad = show . length . show $ quantity
choices = zip valids $ toList choiceLabels
traverse_ (\(l,v) -> printf ("%" <> pad <> "s. %s\n") l (f v)) choices
putStr ">> "
hFlush stdout
userChoice <- getLine
case userChoice `lookup` choices of
Just valid -> pure valid
Nothing -> getSelection f choiceLabels
ifFile :: MonadIO m => (a -> m a) -> m b -> Path Absolute -> a -> m a
ifFile t f file x = liftIO (doesFileExist file) >>= bool (f $> x) (t x)
urlContents :: Manager -> String -> IO (Maybe L.ByteString)
urlContents m url = f <$> httpLbs (parseRequest_ url) m
where f res | statusCode (responseStatus res) == 200 = Just $ responseBody res
| otherwise = Nothing
csi :: [Int] -> T.Text -> T.Text
csi args code = "\ESC[" <> T.intercalate ";" (map (T.pack . show) args) <> code
cursorUpLineCode :: Int -> T.Text
cursorUpLineCode n = csi [n] "F"
getTrueUser :: Environment -> Maybe User
getTrueUser env | isTrueRoot env = Just $ User "root"
| hasRootPriv env = User <$> M.lookup "SUDO_USER" env
| otherwise = User <$> M.lookup "USER" env
isTrueRoot :: Environment -> Bool
isTrueRoot env = M.lookup "USER" env == Just "root" && not (M.member "SUDO_USER" env)
hasRootPriv :: Environment -> Bool
hasRootPriv env = M.member "SUDO_USER" env || isTrueRoot env
getEditor :: Environment -> FilePath
getEditor = maybe "vi" T.unpack . M.lookup "EDITOR"
getLocale :: Environment -> T.Text
getLocale env = fromMaybe "C" . asum $ map (`M.lookup` env) ["LC_ALL", "LC_MESSAGES", "LANG"]
chown :: MonadIO m => User -> Path Absolute -> [String] -> m ()
chown (User usr) pth args = void . runProcess $ proc "chown" (args <> [T.unpack usr, toFilePath pth])
hideCursor :: IO ()
hideCursor = T.putStr hideCursorCode
showCursor :: IO ()
showCursor = T.putStr showCursorCode
hideCursorCode :: T.Text
hideCursorCode = csi [] "?25l"
showCursorCode :: T.Text
showCursorCode = csi [] "?25h"
raiseCursorBy :: Int -> IO ()
raiseCursorBy = T.putStr . cursorUpLineCode
putStrLnA :: Settings -> Doc AnsiStyle -> IO ()
putStrLnA ss d = putStrA ss $ d <> hardline
putStrA :: Settings -> Doc AnsiStyle -> IO ()
putStrA ss d = T.putStr . dtot $ "aura >>=" <+> colourCheck ss d
colourCheck :: Settings -> Doc ann -> Doc ann
colourCheck ss | shared ss (Colour Never) = unAnnotate
| shared ss (Colour Always) = id
| isTerminal ss = id
| otherwise = unAnnotate
yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt ss msg = do
putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " "
hFlush stdout
response <- T.getLine
pure $ isAffirmative (langOf ss) response
isAffirmative :: Language -> T.Text -> Bool
isAffirmative l t = T.null t || elem t (yesPattern l)
optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool
optionalPrompt ss msg | shared ss NoConfirm = pure True
| otherwise = yesNoPrompt ss (msg $ langOf ss)
entrify :: Settings -> [T.Text] -> [Doc AnsiStyle] -> Doc AnsiStyle
entrify ss fs es = vsep $ zipWith combine fs' es
where fs' = padding ss fs
combine f e = annotate bold (pretty f) <+> ":" <+> e
padding :: Settings -> [T.Text] -> [T.Text]
padding ss fs = map (T.justifyLeft longest ws) fs
where ws = whitespace $ langOf ss
longest = maximum $ map T.length fs
maybe' :: b -> Maybe a -> (a -> b) -> b
maybe' zero m f = maybe zero f m