{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TypeOperators     #-}

module Hyperion.Util where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.Except
import           Data.BinaryHash       (hashBase64Safe)
import qualified Data.ByteString.Char8 as B
import           Data.Constraint       (Constraint, Dict (..))
import           Data.IORef            (IORef, atomicModifyIORef', newIORef)
import           Data.Text             (Text)
import qualified Data.Text             as Text
import qualified Data.Text.Lazy        as LazyText
import           Data.Time.Clock       (NominalDiffTime)
import qualified Data.Vector           as V
import qualified Hyperion.Log          as Log
import           Network.Mail.Mime     (Address (..), renderSendMail,
                                        simpleMail')
import           Numeric               (showIntAtBase)
import           System.Directory
import           System.FilePath.Posix (replaceDirectory)
import           System.IO.Unsafe      (unsafePerformIO)
import           System.Posix.Files    (readSymbolicLink)
import           System.Random         (randomRIO)
import qualified Text.ShellEscape      as Esc

-- | An opaque type representing a unique object. Only guaranteed to
-- be unique in one instance of a running program. For example, if we
-- allowed Unique's to be serialized and sent across the wire, or
-- stored and retrieved from a database, they would no longer be
-- guaranteed to be unique.
newtype Unique = MkUnique Integer
  deriving (Unique -> Unique -> Bool
(Unique -> Unique -> Bool)
-> (Unique -> Unique -> Bool) -> Eq Unique
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unique -> Unique -> Bool
$c/= :: Unique -> Unique -> Bool
== :: Unique -> Unique -> Bool
$c== :: Unique -> Unique -> Bool
Eq, Eq Unique
Eq Unique
-> (Unique -> Unique -> Ordering)
-> (Unique -> Unique -> Bool)
-> (Unique -> Unique -> Bool)
-> (Unique -> Unique -> Bool)
-> (Unique -> Unique -> Bool)
-> (Unique -> Unique -> Unique)
-> (Unique -> Unique -> Unique)
-> Ord Unique
Unique -> Unique -> Bool
Unique -> Unique -> Ordering
Unique -> Unique -> Unique
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Unique -> Unique -> Unique
$cmin :: Unique -> Unique -> Unique
max :: Unique -> Unique -> Unique
$cmax :: Unique -> Unique -> Unique
>= :: Unique -> Unique -> Bool
$c>= :: Unique -> Unique -> Bool
> :: Unique -> Unique -> Bool
$c> :: Unique -> Unique -> Bool
<= :: Unique -> Unique -> Bool
$c<= :: Unique -> Unique -> Bool
< :: Unique -> Unique -> Bool
$c< :: Unique -> Unique -> Bool
compare :: Unique -> Unique -> Ordering
$ccompare :: Unique -> Unique -> Ordering
$cp1Ord :: Eq Unique
Ord)

-- | A Unique can be rendered to a unique string of the characters
-- [0-9a-zA-Z]. This is used in Hyperion.Remote to generate new
-- ServiceId's.
instance Show Unique where
  show :: Unique -> String
show (MkUnique Integer
c) = Integer -> (Int -> Char) -> Integer -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Char -> Int
forall a. Vector a -> Int
V.length Vector Char
chars)) ((Vector Char
chars Vector Char -> Int -> Char
forall a. Vector a -> Int -> a
V.!) (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Integer
c String
""
    where
      chars :: Vector Char
chars = String -> Vector Char
forall a. [a] -> Vector a
V.fromList (String -> Vector Char) -> String -> Vector Char
forall a b. (a -> b) -> a -> b
$ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']

uniqueSource :: IORef Integer
uniqueSource :: IORef Integer
uniqueSource = IO (IORef Integer) -> IORef Integer
forall a. IO a -> a
unsafePerformIO (Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0)
{-# NOINLINE uniqueSource #-}

-- | Get a new Unique.
newUnique :: IO Unique
newUnique :: IO Unique
newUnique = (Integer -> Unique) -> IO Integer -> IO Unique
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Unique
MkUnique (IO Integer -> IO Unique) -> IO Integer -> IO Unique
forall a b. (a -> b) -> a -> b
$ IORef Integer -> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
uniqueSource ((Integer -> (Integer, Integer)) -> IO Integer)
-> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Integer
c -> (Integer
cInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,Integer
c)

-- | 'IO' action that returns a random string of given length
randomString :: Int -> IO String
randomString :: Int -> IO String
randomString Int
len = Int -> IO Char -> IO String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len (IO Char -> IO String) -> IO Char -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> Char
forall p. Enum p => Int -> p
toAlpha (Int -> Char) -> IO Int -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0, Int
51)
  where toAlpha :: Int -> p
toAlpha Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
26    = Int -> p
forall p. Enum p => Int -> p
toEnum (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A')
                  | Bool
otherwise = Int -> p
forall p. Enum p => Int -> p
toEnum (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
26 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a')

-- | @retryRepeated n doTry m@ tries to run @doTry m@ n-1 times, after
-- which it runs @m@ 1 time. After each failure waits 15-90 seconds
-- randomly. Returns on first success.  Failure is represented by a
-- 'Left' value.
retryRepeated
  :: (Show e, MonadIO m)
  => Int -- ^ If this is 0 (or less), then it attempt @doTry m@ indefinitely.
  -> (m a -> m (Either e a))
  -> m a
  -> m a
retryRepeated :: Int -> (m a -> m (Either e a)) -> m a -> m a
retryRepeated Int
n m a -> m (Either e a)
doTry m a
m = Int -> m a
forall t. (Eq t, Num t) => t -> m a
go Int
n
  where
    go :: t -> m a
go t
1 = m a
m
    go t
k = m a -> m (Either e a)
doTry m a
m m (Either e a) -> (Either e a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left e
e  -> e -> m ()
forall (m :: * -> *) e. (MonadIO m, Show e) => e -> m ()
wait e
e m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> m a
go (t
kt -> t -> t
forall a. Num a => a -> a -> a
-t
1)
      Right a
b -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
    wait :: e -> m ()
wait e
e = do
      Int
t <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
15, Int
90)
      Text -> WaitRetry e -> m ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
Log.warn Text
"Unsuccessful" (e -> Int -> WaitRetry e
forall e. e -> Int -> WaitRetry e
WaitRetry e
e Int
t)
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000

data WaitRetry e = WaitRetry
  { WaitRetry e -> e
err      :: e
  , WaitRetry e -> Int
waitTime :: Int
  } deriving Int -> WaitRetry e -> ShowS
[WaitRetry e] -> ShowS
WaitRetry e -> String
(Int -> WaitRetry e -> ShowS)
-> (WaitRetry e -> String)
-> ([WaitRetry e] -> ShowS)
-> Show (WaitRetry e)
forall e. Show e => Int -> WaitRetry e -> ShowS
forall e. Show e => [WaitRetry e] -> ShowS
forall e. Show e => WaitRetry e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaitRetry e] -> ShowS
$cshowList :: forall e. Show e => [WaitRetry e] -> ShowS
show :: WaitRetry e -> String
$cshow :: forall e. Show e => WaitRetry e -> String
showsPrec :: Int -> WaitRetry e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> WaitRetry e -> ShowS
Show

-- | @retryExponential doTry m@ tries to run @doTry m@. After the n-th
-- successive failure, it waits time 2^n*t0, where t0 is a randomly
-- chosen time between 10 and 20 seconds. Unlike 'retryRepeated',
-- 'retryExponential' never eventually throws an exception, so it
-- should only be used when the only way to recover from the exception
-- without the whole program crashing is to retry until things
-- work. Typically this means it should only be used in the master
-- process.
retryExponential
  :: MonadIO m
  => (m a -> m (Either e a))
  -> (WaitRetry e -> m ())
  -> m a
  -> m a
retryExponential :: (m a -> m (Either e a)) -> (WaitRetry e -> m ()) -> m a -> m a
retryExponential m a -> m (Either e a)
doTry WaitRetry e -> m ()
handleErr m a
m = Int -> m a
go Int
1
  where
    go :: Int -> m a
go Int
timeMultiplier = m a -> m (Either e a)
doTry m a
m m (Either e a) -> (Either e a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left e
e  -> Int -> e -> m ()
wait Int
timeMultiplier e
e m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m a
go (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
timeMultiplier)
      Right a
b -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
    wait :: Int -> e -> m ()
wait Int
timeMultiplier e
e = do
      Int
t <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> (IO Int -> IO Int) -> IO Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
timeMultiplier) (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
10, Int
20)
      WaitRetry e -> m ()
handleErr (e -> Int -> WaitRetry e
forall e. e -> Int -> WaitRetry e
WaitRetry e
e Int
t)
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000

-- | Send an email to 'toAddr' with the given 'subject' and 'body'.
emailMessage
  :: MonadIO m
  => Text
  -> Text
  -> Text
  -> m ()
emailMessage :: Text -> Text -> Text -> m ()
emailMessage Text
toAddr Text
subject Text
body = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Mail -> IO ()
renderSendMail Mail
mail
  where
    mail :: Mail
mail      = Address -> Address -> Text -> Text -> Mail
simpleMail' Address
toAddr' Address
fromAddr' Text
subject (Text -> Text
LazyText.fromStrict Text
body)
    toAddr' :: Address
toAddr'   = Maybe Text -> Text -> Address
Address Maybe Text
forall a. Maybe a
Nothing Text
toAddr
    fromAddr' :: Address
fromAddr' = Maybe Text -> Text -> Address
Address (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hyperion") Text
toAddr

-- | Send an email to 'toAddr' showing the object 'a'. The subject
-- line is "msg: ...", where 'msg' is the first argument and "..." is
-- the first 40 characters of 'show a'.
email :: (Show a, MonadIO m) => Text -> Text -> a -> m ()
email :: Text -> Text -> a -> m ()
email Text
msg Text
toAddr a
a = Text -> Text -> Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> Text -> Text -> m ()
emailMessage Text
toAddr Text
subject Text
body
  where
    subject :: Text
subject = Text
"[Hyperion] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
40 (String -> Text
Text.pack (a -> String
forall a. Show a => a -> String
show a
a))
    body :: Text
body = a -> Text
forall a. Show a => a -> Text
Log.prettyShowText a
a

-- | Send an email with msg "Error"
emailError :: (Show a, MonadIO m) => Text -> a -> m ()
emailError :: Text -> a -> m ()
emailError = Text -> Text -> a -> m ()
forall a (m :: * -> *).
(Show a, MonadIO m) =>
Text -> Text -> a -> m ()
email Text
"Error"

-- | Takes a path and a list of 'String' arguments, shell-escapes the arguments,
-- and combines everything into a single string.
shellEsc :: FilePath -> [String] -> String
shellEsc :: String -> [String] -> String
shellEsc String
cmd [String]
args = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
B.unpack (ByteString -> String) -> (String -> ByteString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sh -> ByteString
forall t. Escape t => t -> ByteString
Esc.bytes (Sh -> ByteString) -> (String -> Sh) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Sh
Esc.sh (ByteString -> Sh) -> (String -> ByteString) -> String -> Sh
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack) [String]
args

----------------- Time ----------------------

minute :: NominalDiffTime
minute :: NominalDiffTime
minute = NominalDiffTime
60

hour :: NominalDiffTime
hour :: NominalDiffTime
hour = NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
minute

day :: NominalDiffTime
day :: NominalDiffTime
day = NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
hour

nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int
nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int
nominalDiffTimeToMicroseconds NominalDiffTime
t = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime
tNominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
1000NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
1000)

----------------- Filesystem ----------------------

myExecutable :: IO FilePath
myExecutable :: IO String
myExecutable = String -> IO String
readSymbolicLink String
"/proc/self/exe"

-- | Determine the path to this executable and save a copy to the specified dir
-- with a string appended to filename.
savedExecutable
  :: FilePath
  -> String -- ^ the string to append
  -> IO FilePath
savedExecutable :: String -> String -> IO String
savedExecutable String
dir String
idString = do
  String
selfExec <- IO String
myExecutable
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
  let savedExec :: String
savedExec = String -> ShowS
replaceDirectory (String
selfExec String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
idString) String
dir
  String -> String -> IO ()
copyFile String
selfExec String
savedExec
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
savedExec

-- | Replaces all non-allowed characters by @\'_\'@. Allowed characters are alphanumerics and .,-,_
sanitizeFileString :: String -> FilePath
sanitizeFileString :: ShowS
sanitizeFileString = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
allowed then Char
'_' else Char
c)
  where
    allowed :: String
allowed = [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".-_"

-- | Truncates a string to a string of at most given length, replacing dropped
-- characters by a hash. The hash takes up 43 symbols,
-- so asking for a smaller length will still return 43 symbols.
hashTruncateString :: Int -> String -> String
hashTruncateString :: Int -> ShowS
hashTruncateString Int
len String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len = String
s
hashTruncateString Int
len String
s =
  Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
numTake String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
numTake Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then String
"-" else String
"") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hString
  where
    numTake :: Int
numTake = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
44
    hString :: String
hString  = ShowS
forall a. (Binary a, Typeable a) => a -> String
hashBase64Safe (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
numTake String
s)

-- | Synonim for @'hashTruncateString' 230@
hashTruncateFileName :: String -> String
hashTruncateFileName :: ShowS
hashTruncateFileName = Int -> ShowS
hashTruncateString Int
230

-- | Turn an expression with a constraint into a function of an
-- explicit dictionary
withDict :: forall (c :: Constraint) r . (c => r) -> Dict c -> r
withDict :: (c => r) -> Dict c -> r
withDict c => r
r Dict c
Dict = r
c => r
r