{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}

module Instrument.Utils
    ( formatDecimal
    , formatInt
    , showT
    , showBS
    , collect
    , noDots
    , encodeCompress
    , decodeCompress
    , indefinitely
    , seconds
    , milliseconds
    , for
    ) where


-------------------------------------------------------------------------------
import           Codec.Compression.GZip
import           Control.Applicative    ((<|>))
import           Control.Concurrent     (threadDelay)
import           Control.Exception      (SomeException)
import           Control.Monad
import           Control.Monad.Catch    (Handler (..))
import           Control.Retry
import qualified Data.ByteString.Char8  as B
import           Data.ByteString.Lazy   (fromStrict, toStrict)
import qualified Data.Map               as M
import qualified Data.Map.Strict        as MS
import qualified Data.SafeCopy          as SC
import           Data.Serialize
import           Data.Text              (Text)
import qualified Data.Text              as T
import           Numeric
import           System.IO
-------------------------------------------------------------------------------



-------------------------------------------------------------------------------
collect :: (Ord b)
        => [a]
        -> (a -> b)
        -> (a -> c)
        -> M.Map b [c]
collect :: [a] -> (a -> b) -> (a -> c) -> Map b [c]
collect [a]
as a -> b
mkKey a -> c
mkVal = (a -> Map b [c] -> Map b [c]) -> Map b [c] -> [a] -> Map b [c]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Map b [c] -> Map b [c]
step Map b [c]
forall k a. Map k a
M.empty [a]
as
    where
      step :: a -> Map b [c] -> Map b [c]
step a
x Map b [c]
acc = ([c] -> [c] -> [c]) -> b -> [c] -> Map b [c] -> Map b [c]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MS.insertWith [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
(++) (a -> b
mkKey a
x) ([a -> c
mkVal a
x]) Map b [c]
acc


-------------------------------------------------------------------------------
noDots :: Text -> Text
noDots :: Text -> Text
noDots = Text -> [Text] -> Text
T.intercalate Text
"_" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"."


-------------------------------------------------------------------------------
showT :: Show a => a -> Text
showT :: a -> Text
showT = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

showBS :: Show a => a -> B.ByteString
showBS :: a -> ByteString
showBS = String -> ByteString
B.pack (String -> ByteString) -> (a -> String) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-------------------------------------------------------------------------------
formatInt :: RealFrac a => a -> Text
formatInt :: a -> Text
formatInt a
i = Int -> Text
forall a. Show a => a -> Text
showT ((a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor a
i) :: Int)


-------------------------------------------------------------------------------
formatDecimal
    :: RealFloat a
    => Int
    -- ^ Digits after the point
    -> Bool
    -- ^ Add thousands sep?
    -> a
    -- ^ Number
    -> Text
formatDecimal :: Int -> Bool -> a -> Text
formatDecimal Int
n Bool
th a
i =
    let res :: Text
res = String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> a -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n) a
i (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
""
    in if Bool
th then Text -> Text
addThousands Text
res else Text
res



-------------------------------------------------------------------------------
addThousands :: Text -> Text
addThousands :: Text -> Text
addThousands Text
t = [Text] -> Text
T.concat [Text
n', Text
dec]
    where
      (Text
n,Text
dec) = (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
t
      n' :: Text
n' = Text -> Text
T.reverse (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
T.chunksOf Int
3 (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.reverse (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
n


-------------------------------------------------------------------------------
-- | Serialize and compress with GZip in that order. This is the only
-- function we use for serializing to Redis.
encodeCompress :: SC.SafeCopy a => a -> B.ByteString
encodeCompress :: a -> ByteString
encodeCompress = ByteString -> ByteString
toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
compress (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutLazy (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall a. SafeCopy a => a -> Put
SC.safePut

-------------------------------------------------------------------------------
-- | Decompress from GZip and deserialize in that order. Tries to
-- decode SafeCopy first and falls back to Serialize if that fails to
-- account for old data. Note that encodeCompress only serializes to
-- SafeCopy so writes will be updated.
decodeCompress :: (SC.SafeCopy a, Serialize a) => B.ByteString -> Either String a
decodeCompress :: ByteString -> Either String a
decodeCompress = ByteString -> Either String a
forall a.
(SafeCopy a, Serialize a) =>
ByteString -> Either String a
decodeWithFallback (ByteString -> Either String a)
-> (ByteString -> ByteString) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decompress (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict
  where
    decodeWithFallback :: ByteString -> Either String a
decodeWithFallback ByteString
lbs = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGetLazy Get a
forall a. SafeCopy a => Get a
SC.safeGet ByteString
lbs Either String a -> Either String a -> Either String a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Either String a
forall a. Serialize a => ByteString -> Either String a
decodeLazy ByteString
lbs


-------------------------------------------------------------------------------
-- | Run an IO repeatedly with the given delay in microseconds. If
-- there are exceptions in the inner loop, they are logged to stderr,
-- prefixed with the given string context and retried at an exponential
-- backoff capped at 60 seconds between.
indefinitely :: String -> Int -> IO () -> IO ()
indefinitely :: String -> Int -> IO () -> IO ()
indefinitely String
ctx Int
n = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO ()
delayed (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO () -> IO ()
logAndBackoff String
ctx
  where
    delayed :: IO a -> IO ()
delayed = (IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
n)


-------------------------------------------------------------------------------
logAndBackoff :: String -> IO () -> IO ()
logAndBackoff :: String -> IO () -> IO ()
logAndBackoff String
ctx = RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO ())
-> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicyM IO
forall (m :: * -> *). Monad m => RetryPolicyM m
policy [RetryStatus -> Handler IO Bool
forall p. p -> Handler IO Bool
h] ((RetryStatus -> IO ()) -> IO ())
-> (IO () -> RetryStatus -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> RetryStatus -> IO ()
forall a b. a -> b -> a
const
  where
    policy :: RetryPolicyM m
policy = Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay (Int -> Int
seconds Int
60) (Int -> forall (m :: * -> *). Monad m => RetryPolicyM m
exponentialBackoff (Int -> Int
milliseconds Int
50))
    h :: p -> Handler IO Bool
h p
_ = (SomeException -> IO Bool) -> Handler IO Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\SomeException
e -> SomeException -> IO ()
logError SomeException
e IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    logError :: SomeException -> IO ()
    logError :: SomeException -> IO ()
logError SomeException
e = Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
      where
        msg :: String
msg = String
"Caught exception in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Retrying..."


-------------------------------------------------------------------------------
-- | Convert seconds to microseconds
seconds :: Int -> Int
seconds :: Int -> Int
seconds = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
milliseconds Int
1000)


-------------------------------------------------------------------------------
-- | Convert milliseconds to microseconds
milliseconds :: Int -> Int
milliseconds :: Int -> Int
milliseconds = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)


-------------------------------------------------------------------------------
for :: (Functor f) => f a -> (a -> b) -> f b
for :: f a -> (a -> b) -> f b
for = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap