{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Provides internal utility functions
module Charon.Utils
  ( -- * FAM combinators
    throwIfEx,
    whenM,

    -- * Text
    matchesWildcards,
    stripInfix,

    -- * ByteString
    breakEqBS,

    -- ** Percent encoding
    percentEncode,
    percentDecode,

    -- * Optics
    mergeAlt,
    merge,

    -- * Bytes formatting
    normalizedFormat,
    formatBytes,

    -- * Logs
    readLogLevel,
    logLevelStrings,

    -- * PathSize
    getPathSize,
    getPathSizeIgnoreDirSize,
    getSymLinkSize,

    -- * Misc
    filterSeqM,
    renderPretty,
    setRefIfJust,
    noBuffering,
    getAllFiles,
    localTimeToMillis,
    getRandomTmpFile,
  )
where

import Charon.Prelude
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy qualified as BSL
import Data.Bytes (FromInteger (afromInteger))
import Data.Bytes qualified as Bytes
import Data.Bytes.Class.Wrapper (Unwrapper (Unwrapped))
import Data.Bytes.Formatting (FloatingFormatter (MkFloatingFormatter))
import Data.Bytes.Formatting.Base (BaseFormatter)
import Data.Bytes.Size (Sized)
import Data.Char qualified as Ch
import Data.Sequence qualified as Seq
import Data.Text qualified as T
import Data.Text.Internal (Text (Text))
import Data.Text.Internal qualified as TI
import Data.Text.Internal.Search qualified as TIS
import Data.Time (LocalTime, UTCTime)
import Data.Time qualified as Time
import Data.Time.Clock.POSIX qualified as Time.Posix
import Effects.FileSystem.HandleWriter qualified as HW
import Effects.FileSystem.PathReader qualified as PR
import Effects.System.PosixCompat qualified as Posix
import Effects.Time (MonadTime (getMonotonicTime))
import PathSize
  ( PathSizeResult
      ( PathSizeFailure,
        PathSizePartial,
        PathSizeSuccess
      ),
  )
import PathSize qualified
import PathSize.Data.Config qualified as PathSize.Config
import System.IO qualified as IO
import System.PosixCompat.Files qualified as PFiles
import Text.Printf (PrintfArg)
import URI.ByteString qualified as URI

-- | Normalizes and formats the bytes.
normalizedFormat :: Bytes B Natural -> Text
normalizedFormat :: Bytes 'B Natural -> Text
normalizedFormat =
  SomeSize Double -> Text
forall a.
(BaseFormatter (Unwrapped a) ~ FloatingFormatter,
 PrintfArg (Unwrapped a), Sized a, Unwrapper a) =>
a -> Text
formatBytes
    (SomeSize Double -> Text)
-> (Bytes 'B Natural -> SomeSize Double)
-> Bytes 'B Natural
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes 'B Double -> Norm (Bytes 'B Double)
Bytes 'B Double -> SomeSize Double
forall a. Normalize a => a -> Norm a
Bytes.normalize
    (Bytes 'B Double -> SomeSize Double)
-> (Bytes 'B Natural -> Bytes 'B Double)
-> Bytes 'B Natural
-> SomeSize Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes 'B Natural -> Bytes 'B Double
forall (s :: Size). Bytes s Natural -> Bytes s Double
toDouble
  where
    toDouble :: Bytes s Natural -> Bytes s Double
    toDouble :: forall (s :: Size). Bytes s Natural -> Bytes s Double
toDouble = (Natural -> Double) -> Bytes s Natural -> Bytes s Double
forall a b. (a -> b) -> Bytes s a -> Bytes s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Formats the bytes.
formatBytes ::
  ( BaseFormatter (Unwrapped a) ~ FloatingFormatter,
    PrintfArg (Unwrapped a),
    Sized a,
    Unwrapper a
  ) =>
  a ->
  Text
formatBytes :: forall a.
(BaseFormatter (Unwrapped a) ~ FloatingFormatter,
 PrintfArg (Unwrapped a), Sized a, Unwrapper a) =>
a -> Text
formatBytes =
  BaseFormatter (Unwrapped a) -> SizedFormatter -> a -> Text
forall a.
(Formatter (BaseFormatter (Unwrapped a)), PrintfArg (Unwrapped a),
 Sized a, Unwrapper a) =>
BaseFormatter (Unwrapped a) -> SizedFormatter -> a -> Text
Bytes.formatSized
    (Maybe Word8 -> FloatingFormatter
MkFloatingFormatter (Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
2))
    SizedFormatter
Bytes.sizedFormatterUnix

-- | Reads the 'LogLevel'.
readLogLevel :: (MonadFail m) => Text -> m (Maybe LogLevel)
readLogLevel :: forall (m :: * -> *). MonadFail m => Text -> m (Maybe LogLevel)
readLogLevel Text
"none" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LogLevel
forall a. Maybe a
Nothing
readLogLevel Text
"fatal" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
levelFatal
readLogLevel Text
"error" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelError
readLogLevel Text
"warn" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelWarn
readLogLevel Text
"info" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelInfo
readLogLevel Text
"debug" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelDebug
readLogLevel Text
"trace" = Maybe LogLevel -> m (Maybe LogLevel)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LogLevel -> m (Maybe LogLevel))
-> Maybe LogLevel -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
levelTrace
readLogLevel Text
other =
  String -> m (Maybe LogLevel)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    (String -> m (Maybe LogLevel)) -> String -> m (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Expected log-level ",
        String
logLevelStrings,
        String
", received: ",
        Text -> String
T.unpack Text
other
      ]

-- | String description of possible log levels parsed by 'readLogLevel'.
logLevelStrings :: String
logLevelStrings :: String
logLevelStrings = String
"(none|fatal|error|warn|info|debug|trace)"

-- | Merge two fields using the 'Alternative' instance.
mergeAlt ::
  (Alternative f) =>
  Lens' s (f a) ->
  Lens' t (f a) ->
  s ->
  t ->
  f a
mergeAlt :: forall (f :: * -> *) s a t.
Alternative f =>
Lens' s (f a) -> Lens' t (f a) -> s -> t -> f a
mergeAlt = (f a -> f a -> f a)
-> Lens' s (f a) -> Lens' t (f a) -> s -> t -> f a
forall a s t.
(a -> a -> a) -> Lens' s a -> Lens' t a -> s -> t -> a
merge f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Merge two fields using the given function.
merge ::
  (a -> a -> a) ->
  Lens' s a ->
  Lens' t a ->
  s ->
  t ->
  a
merge :: forall a s t.
(a -> a -> a) -> Lens' s a -> Lens' t a -> s -> t -> a
merge a -> a -> a
f Lens' s a
sLens Lens' t a
tLens s
s t
t = (s
s s -> Lens' s a -> a
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' s a
sLens) a -> a -> a
`f` (t
t t -> Lens' t a -> a
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' t a
tLens)

-- | Renders via pretty instance.
renderPretty :: (Pretty a) => a -> Text
renderPretty :: forall a. Pretty a => a -> Text
renderPretty =
  SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict
    (SimpleDocStream Any -> Text)
-> (a -> SimpleDocStream Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> SimpleDocStream Any
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact
    (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- | @matchesWildcards matchStr toMatch@ returns true if @toMatch@ "matches"
-- the @matchStr@, where unescaped asterisks in @matchStr@ are interpreted
-- as wildcards.
matchesWildcards :: Text -> Text -> Bool
matchesWildcards :: Text -> Text -> Bool
matchesWildcards Text
matchStr Text
toMatch = case Text -> [Text]
splitMatchStr Text
matchStr of
  -- Impossible
  [] -> Bool
False
  (Text
m : [Text]
ms) -> case Text -> Text -> Maybe Text
T.stripPrefix Text
m Text
toMatch of
    Maybe Text
Nothing -> Bool
False
    Just Text
toMatch' -> [Text] -> Text -> Bool
go [Text]
ms Text
toMatch'
  where
    go :: [Text] -> Text -> Bool
go [] Text
s = Text -> Bool
T.null Text
s
    go [Text
""] Text
_ = Bool
True
    -- NOTE: Why stripInfix? Say we have @matchesWildcards "foo*bar" "foobazbar"@.
    -- After the first case split above, we will have @go ["bar"] "bazbar"@.
    -- The '*' is meant to match to the right as far as possible, so we need
    -- the __first__ occurrence of "bar", wherever that occurs, which is
    -- exactly what stripInfix does.
    go (Text
m : [Text]
ms) Text
s = case Text -> Text -> Maybe (Text, Text)
stripInfix Text
m Text
s of
      Maybe (Text, Text)
Nothing -> Bool
False
      Just (Text
_, Text
s') -> [Text] -> Text -> Bool
go [Text]
ms Text
s'

    -- Because the matchStr may contain literal '*'s not representing wildcards
    -- (written as "\*"), we do not want to include them in the split.
    -- Thus we first map them to null bytes (unix paths cannot contain null
    -- bytes), then add them back.
    splitMatchStr :: Text -> [Text]
    splitMatchStr :: Text -> [Text]
splitMatchStr =
      (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\0" Text
"*")
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*')
        (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\*" Text
"\0"

-- | @stripInfix text needle@ strips the _first_ occurrence of needle
-- from the text.
stripInfix :: Text -> Text -> Maybe (Text, Text)
stripInfix :: Text -> Text -> Maybe (Text, Text)
stripInfix Text
"" Text
t = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"", Text
t)
stripInfix p :: Text
p@(Text Array
_arr Int
_off Int
plen) t :: Text
t@(Text Array
arr Int
off Int
len) =
  case Text -> Text -> [Int]
TIS.indices Text
p Text
t of
    [] -> Maybe (Text, Text)
forall a. Maybe a
Nothing
    (Int
x : [Int]
_) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Array -> Int -> Int -> Text
TI.text Array
arr Int
off Int
x, Array -> Int -> Int -> Text
TI.text Array
arr (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
plen) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
plen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x))

-- | Sets the ioref if the maybe is non-empty.
setRefIfJust :: (MonadIORef m) => IORef (Maybe a) -> Maybe a -> m ()
setRefIfJust :: forall (m :: * -> *) a.
MonadIORef m =>
IORef (Maybe a) -> Maybe a -> m ()
setRefIfJust IORef (Maybe a)
_ Maybe a
Nothing = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setRefIfJust IORef (Maybe a)
ref x :: Maybe a
x@(Just a
_) = IORef (Maybe a) -> Maybe a -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: * -> *) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef (Maybe a)
ref Maybe a
x

-- | Throws the exception if it exists in the ref.
throwIfEx ::
  ( MonadIORef m,
    MonadThrow m
  ) =>
  IORef (Maybe SomeException) ->
  m ()
throwIfEx :: forall (m :: * -> *).
(MonadIORef m, MonadThrow m) =>
IORef (Maybe SomeException) -> m ()
throwIfEx IORef (Maybe SomeException)
ref =
  IORef (Maybe SomeException) -> m (Maybe SomeException)
forall a. HasCallStack => IORef a -> m a
forall (m :: * -> *) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef (Maybe SomeException)
ref m (Maybe SomeException) -> (Maybe SomeException -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe SomeException
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just SomeException
ex -> SomeException -> m ()
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS SomeException
ex

-- | Breaks a bytestring on the first '='. The '=' is removed from the second
-- element.
breakEqBS :: ByteString -> (ByteString, ByteString)
breakEqBS :: ByteString -> (ByteString, ByteString)
breakEqBS ByteString
bs = (ByteString
left, ByteString
right')
  where
    (ByteString
left, ByteString
right) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') ByteString
bs
    right' :: ByteString
right' = case ByteString -> Maybe (Char, ByteString)
C8.uncons ByteString
right of
      Maybe (Char, ByteString)
Nothing -> ByteString
""
      Just (Char
_, ByteString
rest) -> ByteString
rest

-- | Percent encoded a bytestring.
percentEncode :: ByteString -> ByteString
percentEncode :: ByteString -> ByteString
percentEncode =
  ByteString -> ByteString
BSL.toStrict
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString
    (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString -> Builder
URI.urlEncode [Word8]
unreserved
  where
    -- NOTE: This is the 'mark' set defined by RFC2396 and the '/' character
    -- with one modification: The mark characters !, *, ', (, ) are excluded.
    --
    -- As the successor RFC3986 notes, these characters can be dangerous
    -- to decode, thus they were in fact moved to the 'reserved' section in
    -- that RFC.
    --
    -- Moreover, KDE Plasma's trash implementation indeed encoded these chars
    -- as well.
    --
    -- Thus we do the same thing here.
    unreserved :: [Word8]
unreserved =
      Char -> Word8
ord8
        (Char -> Word8) -> String -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Char
'/',
              Char
'-',
              Char
'_',
              Char
'.',
              Char
'~'
            ]

    ord8 :: Char -> Word8
    ord8 :: Char -> Word8
ord8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
Ch.ord

-- | Percent decodes a bytestring.
percentDecode :: ByteString -> ByteString
percentDecode :: ByteString -> ByteString
percentDecode = Bool -> ByteString -> ByteString
URI.urlDecode Bool
False

-- | Filter a sequence monadically.
filterSeqM :: forall m a. (Monad m) => (a -> m Bool) -> Seq a -> m (Seq a)
filterSeqM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Seq a -> m (Seq a)
filterSeqM a -> m Bool
p = (m (Seq a) -> a -> m (Seq a)) -> m (Seq a) -> Seq a -> m (Seq a)
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' m (Seq a) -> a -> m (Seq a)
foldP (Seq a -> m (Seq a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq a
forall a. Seq a
Seq.empty)
  where
    foldP :: m (Seq a) -> a -> m (Seq a)
    foldP :: m (Seq a) -> a -> m (Seq a)
foldP m (Seq a)
acc a
x = do
      Bool
b <- a -> m Bool
p a
x
      if Bool
b
        then (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
:|> a
x) (Seq a -> Seq a) -> m (Seq a) -> m (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Seq a)
acc
        else m (Seq a)
acc

-- | When for monadic bool.
whenM :: (Monad m) => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
mb m ()
ma = m Bool
mb m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` m ()
ma)

-- | Sets NoBuffering.
noBuffering :: (HasCallStack, MonadHandleWriter m) => m ()
noBuffering :: forall (m :: * -> *). (HasCallStack, MonadHandleWriter m) => m ()
noBuffering = Handle -> m ()
forall {m :: * -> *}. MonadHandleWriter m => Handle -> m ()
buffOff Handle
IO.stdin m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Handle -> m ()
forall {m :: * -> *}. MonadHandleWriter m => Handle -> m ()
buffOff Handle
IO.stdout
  where
    buffOff :: Handle -> m ()
buffOff Handle
h = Handle -> BufferMode -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> BufferMode -> m ()
HW.hSetBuffering Handle
h BufferMode
NoBuffering

getPathSize ::
  ( HasCallStack,
    MonadAsync m,
    MonadCatch m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPosixCompat m,
    MonadTerminal m
  ) =>
  OsPath ->
  m (Bytes B Natural)
getPathSize :: forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadTerminal m) =>
OsPath -> m (Bytes 'B Natural)
getPathSize = Config -> OsPath -> m (Bytes 'B Natural)
forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadTerminal m) =>
Config -> OsPath -> m (Bytes 'B Natural)
getPathSizeConfig Config
PathSize.Config.defaultConfig

getPathSizeIgnoreDirSize ::
  ( HasCallStack,
    MonadAsync m,
    MonadCatch m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPosixCompat m,
    MonadTerminal m
  ) =>
  OsPath ->
  m (Bytes B Natural)
getPathSizeIgnoreDirSize :: forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadTerminal m) =>
OsPath -> m (Bytes 'B Natural)
getPathSizeIgnoreDirSize = Config -> OsPath -> m (Bytes 'B Natural)
forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadTerminal m) =>
Config -> OsPath -> m (Bytes 'B Natural)
getPathSizeConfig Config
config
  where
    config :: Config
config = Optic A_Lens NoIx Config Config Bool Bool
-> Bool -> Config -> Config
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set' Optic A_Lens NoIx Config Config Bool Bool
#ignoreDirIntrinsicSize Bool
True Config
PathSize.Config.defaultConfig

getPathSizeConfig ::
  ( HasCallStack,
    MonadAsync m,
    MonadCatch m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPosixCompat m,
    MonadTerminal m
  ) =>
  PathSize.Config ->
  OsPath ->
  m (Bytes B Natural)
getPathSizeConfig :: forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadTerminal m) =>
Config -> OsPath -> m (Bytes 'B Natural)
getPathSizeConfig Config
config OsPath
path = Text -> m (Bytes 'B Natural) -> m (Bytes 'B Natural)
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"getPathSizeConfig" (m (Bytes 'B Natural) -> m (Bytes 'B Natural))
-> m (Bytes 'B Natural) -> m (Bytes 'B Natural)
forall a b. (a -> b) -> a -> b
$ do
  (Natural -> Bytes 'B Natural) -> m Natural -> m (Bytes 'B Natural)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (s :: Size) n. n -> Bytes s n
MkBytes @B)
    (m Natural -> m (Bytes 'B Natural))
-> m Natural -> m (Bytes 'B Natural)
forall a b. (a -> b) -> a -> b
$ Config -> OsPath -> m (PathSizeResult Natural)
forall (m :: * -> *).
(HasCallStack, MonadAsync m, MonadCatch m, MonadPathReader m,
 MonadPosixCompat m) =>
Config -> OsPath -> m (PathSizeResult Natural)
PathSize.pathSizeRecursiveConfig Config
config OsPath
path
    m (PathSizeResult Natural)
-> (PathSizeResult Natural -> m Natural) -> m Natural
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PathSizeSuccess Natural
n -> Natural -> m Natural
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
n
      PathSizePartial NESeq PathE
errs Natural
n -> do
        -- We received a value but had some errors.
        String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
"Encountered errors retrieving size."
        NESeq PathE -> (PathE -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NESeq PathE
errs ((PathE -> m ()) -> m ()) -> (PathE -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PathE
e -> do
          let errMsg :: Text
errMsg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PathE -> String
forall e. Exception e => e -> String
displayException PathE
e
          Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putTextLn Text
errMsg
          $(logWarn) Text
errMsg
        Natural -> m Natural
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
n
      PathSizeFailure NESeq PathE
errs -> do
        String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
"Encountered errors retrieving size. Defaulting to 0. See logs."
        NESeq PathE -> (PathE -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NESeq PathE
errs ((PathE -> m ()) -> m ()) -> (PathE -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PathE
e -> do
          let errMsg :: Text
errMsg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PathE -> String
forall e. Exception e => e -> String
displayException PathE
e
          Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putTextLn Text
errMsg
          $(logWarn) Text
errMsg
        Natural -> m Natural
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0

getAllFiles ::
  ( HasCallStack,
    MonadCatch m,
    MonadLoggerNS m,
    MonadPathReader m
  ) =>
  OsPath ->
  m [OsPath]
getAllFiles :: forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadLoggerNS m, MonadPathReader m) =>
OsPath -> m [OsPath]
getAllFiles OsPath
fp = Text -> m [OsPath] -> m [OsPath]
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"getAllFiles" (m [OsPath] -> m [OsPath]) -> m [OsPath] -> m [OsPath]
forall a b. (a -> b) -> a -> b
$ do
  $(logTrace) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Retrieving files for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OsPath -> Text
decodeOsToFpDisplayExT OsPath
fp
  -- NOTE: [getPathType]
  --
  -- It would be nice to switch this from PathReader's getPathType to
  -- PosixCompact's, as the latter is faster (fewer IO calls). Alas, the latter
  -- is also much harder to mock, which we unfortunately rely on in some tests.
  --
  -- If we figure out how to mock it (or make the tests realer), we can then
  -- swap it.
  OsPath -> m PathType
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m) =>
OsPath -> m PathType
PR.getPathType OsPath
fp m PathType -> (PathType -> m [OsPath]) -> m [OsPath]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PathType
PathTypeSymbolicLink -> [OsPath] -> m [OsPath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OsPath
fp]
    PathType
PathTypeFile -> [OsPath] -> m [OsPath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OsPath
fp]
    PathType
PathTypeOther -> [OsPath] -> m [OsPath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OsPath
fp]
    PathType
PathTypeDirectory ->
      OsPath -> m [OsPath]
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m [OsPath]
listDirectory OsPath
fp
        m [OsPath] -> ([OsPath] -> m [OsPath]) -> m [OsPath]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([[OsPath]] -> [OsPath]) -> m [[OsPath]] -> m [OsPath]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[OsPath]] -> [OsPath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
        (m [[OsPath]] -> m [OsPath])
-> ([OsPath] -> m [[OsPath]]) -> [OsPath] -> m [OsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OsPath -> m [OsPath]) -> [OsPath] -> m [[OsPath]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (OsPath -> m [OsPath]
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadLoggerNS m, MonadPathReader m) =>
OsPath -> m [OsPath]
getAllFiles (OsPath -> m [OsPath])
-> (OsPath -> OsPath) -> OsPath -> m [OsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OsPath
fp </>))

localTimeToMillis :: LocalTime -> Integer
localTimeToMillis :: LocalTime -> Integer
localTimeToMillis = UTCTime -> Integer
utcTimeToMillis (UTCTime -> Integer)
-> (LocalTime -> UTCTime) -> LocalTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> LocalTime -> UTCTime
Time.localTimeToUTC TimeZone
Time.utc

utcTimeToMillis :: UTCTime -> Integer
utcTimeToMillis :: UTCTime -> Integer
utcTimeToMillis = (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000) (Integer -> Integer) -> (UTCTime -> Integer) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Integer
utcTimeToMicros

utcTimeToMicros :: UTCTime -> Integer
utcTimeToMicros :: UTCTime -> Integer
utcTimeToMicros UTCTime
utc =
  DiffTime -> Integer
Time.diffTimeToPicoseconds (POSIXTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
diffTime) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000
  where
    diffTime :: POSIXTime
diffTime = UTCTime -> UTCTime -> POSIXTime
Time.diffUTCTime UTCTime
utc UTCTime
epoch

epoch :: UTCTime
epoch :: UTCTime
epoch = POSIXTime -> UTCTime
Time.Posix.posixSecondsToUTCTime POSIXTime
0

getRandomTmpFile ::
  ( HasCallStack,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadThrow m,
    MonadTime m
  ) =>
  OsPath ->
  m OsPath
getRandomTmpFile :: forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadPathReader m, MonadThrow m,
 MonadTime m) =>
OsPath -> m OsPath
getRandomTmpFile OsPath
prefix = Text -> m OsPath -> m OsPath
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"getRandomTmpFile" (m OsPath -> m OsPath) -> m OsPath -> m OsPath
forall a b. (a -> b) -> a -> b
$ do
  -- NOTE: [File name collisions]
  --
  -- Is getMonotonicTimeNSec less likely to have collisions than
  -- getMonotonicTime? If so, consider switching. We can also add a random
  -- number if we are feeling paranoid.
  OsPath
timeStr <- String -> m OsPath
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
String -> m OsPath
encodeFpToOsThrowM (String -> m OsPath) -> (Double -> String) -> Double -> m OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> m OsPath) -> m Double -> m OsPath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Double
forall (m :: * -> *). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  OsPath
tmpDir <- m OsPath
forall (m :: * -> *). (MonadPathReader m, HasCallStack) => m OsPath
PR.getTemporaryDirectory

  let tmpFile :: OsPath
tmpFile = OsPath
tmpDir OsPath -> OsPath -> OsPath
</> OsPath
prefix OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> [osp|_|] OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> OsPath
timeStr
  $(logDebug) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Generated temp file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OsPath -> Text
decodeOsToFpDisplayExT OsPath
tmpFile

  OsPath -> m OsPath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsPath
tmpFile

getSymLinkSize ::
  ( HasCallStack,
    MonadPosixCompat m,
    MonadThrow m
  ) =>
  OsPath ->
  m (Bytes B Natural)
getSymLinkSize :: forall (m :: * -> *).
(HasCallStack, MonadPosixCompat m, MonadThrow m) =>
OsPath -> m (Bytes 'B Natural)
getSymLinkSize =
  (FileStatus -> Bytes 'B Natural)
-> m FileStatus -> m (Bytes 'B Natural)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Bytes 'B Natural
forall a. (FromInteger a, HasCallStack) => Integer -> a
afromInteger (Integer -> Bytes 'B Natural)
-> (FileStatus -> Integer) -> FileStatus -> Bytes 'B Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileOffset -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Integer)
-> (FileStatus -> FileOffset) -> FileStatus -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
PFiles.fileSize)
    (m FileStatus -> m (Bytes 'B Natural))
-> (String -> m FileStatus) -> String -> m (Bytes 'B Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m FileStatus
forall (m :: * -> *).
(MonadPosixCompat m, HasCallStack) =>
String -> m FileStatus
Posix.getSymbolicLinkStatus
    (String -> m (Bytes 'B Natural))
-> (OsPath -> m String) -> OsPath -> m (Bytes 'B Natural)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< OsPath -> m String
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
OsPath -> m String
decodeOsToFpThrowM