{-# LANGUAGE OverloadedStrings #-}
module Aura.Utils
(
Pattern(..)
, replaceByPatt, searchLines
, urlContents
, csi, cursorUpLineCode, hideCursor, showCursor, raiseCursorBy
, getTrueUser, getEditor, getLocale
, hasRootPriv, isTrueRoot
, chown
, ifFile
, putStrLnA
, putText
, putTextLn
, 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 Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode)
import RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import RIO.List.Partial (maximum)
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Text.Partial (breakOn)
import System.Path (Absolute, Path, toFilePath)
import System.Path.IO (doesFileExist)
import System.Process.Typed (proc, runProcess)
import Text.Printf (printf)
data Pattern = Pattern { _pattern :: Text, _target :: Text }
replaceByPatt :: [Pattern] -> Text -> Text
replaceByPatt [] l = l
replaceByPatt (Pattern p t : ps) l = case breakOn p l of
(_, "") -> replaceByPatt ps l
(cs, rest) -> replaceByPatt ps (cs <> t <> T.drop (T.length p) rest)
searchLines :: Text -> [Text] -> [Text]
searchLines pat = filter (T.isInfixOf pat)
getSelection :: Foldable f => (a -> Text) -> f a -> IO a
getSelection f choiceLabels = do
let quantity = length choiceLabels
valids = map tshow [1..quantity]
pad = show . length . show $ quantity
choices = zip valids $ toList choiceLabels
traverse_ (\(l,v) -> printf ("%" <> pad <> "s. %s\n") l (f v)) choices
BL.putStr ">> "
hFlush stdout
userChoice <- decodeUtf8Lenient <$> B.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 ByteString)
urlContents m url = f <$> httpLbs (parseRequest_ url) m
where
f :: Response BL.ByteString -> Maybe ByteString
f res | statusCode (responseStatus res) == 200 = Just . BL.toStrict $ responseBody res
| otherwise = Nothing
csi :: [Int] -> ByteString -> ByteString
csi args code = "\ESC[" <> B.intercalate ";" (map (encodeUtf8 . textDisplay) args) <> code
cursorUpLineCode :: Int -> ByteString
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 -> 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 = B.putStr hideCursorCode
showCursor :: IO ()
showCursor = B.putStr showCursorCode
hideCursorCode :: ByteString
hideCursorCode = csi [] "?25l"
showCursorCode :: ByteString
showCursorCode = csi [] "?25h"
raiseCursorBy :: Int -> IO ()
raiseCursorBy = B.putStr . cursorUpLineCode
putStrLnA :: Settings -> Doc AnsiStyle -> IO ()
putStrLnA ss d = putStrA ss $ d <> hardline
putStrA :: Settings -> Doc AnsiStyle -> IO ()
putStrA ss d = B.putStr . encodeUtf8 . 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
putText :: Text -> IO ()
putText = B.putStr . encodeUtf8
putTextLn :: Text -> IO ()
putTextLn = BL.putStrLn . BL.fromStrict . encodeUtf8
yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt ss msg = do
putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " "
hFlush stdout
response <- decodeUtf8Lenient <$> B.getLine
pure $ isAffirmative (langOf ss) response
isAffirmative :: Language -> Text -> Bool
isAffirmative l t = T.null t || elem (T.toCaseFold 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 -> [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 -> [Text] -> [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