{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Copyright: © 2020-2021 IOHK
-- License: Apache-2.0
--
-- General utility functions.
--
module Cardano.Wallet.Util
    ( -- * Partial functions for "impossible" situations
      HasCallStack
    , internalError
    , tina
    , invariant

    -- ** Handling errors for "impossible" situations.
    , isInternalError
    , tryInternalError

    -- * String formatting
    , ShowFmt (..)
    , mapFirst

    -- * StateT
    , modifyM

    -- * HTTP(S) URIs
    , uriToText
    , parseURI
    ) where

import Prelude

import Control.DeepSeq
    ( NFData (..) )
import Control.Error.Util
    ( (??) )
import Control.Exception
    ( ErrorCall, displayException )
import Control.Monad.IO.Unlift
    ( MonadUnliftIO )
import Control.Monad.Trans.Class
    ( lift )
import Control.Monad.Trans.Except
    ( runExceptT, throwE )
import Control.Monad.Trans.State.Strict
    ( StateT, get, put )
import Data.Foldable
    ( asum )
import Data.Functor.Identity
    ( runIdentity )
import Data.List
    ( isPrefixOf )
import Data.Maybe
    ( fromMaybe, isNothing )
import Data.Text
    ( Text )
import Data.Text.Class
    ( TextDecodingError (..) )
import Fmt
    ( Buildable (..), Builder, fmt, (+|) )
import GHC.Generics
    ( Generic )
import GHC.Stack
    ( HasCallStack )
import Network.URI
    ( URI (..), parseAbsoluteURI, uriQuery, uriScheme, uriToString )
import UnliftIO.Exception
    ( evaluate, tryJust )

import qualified Data.Text as T

-- | Calls the 'error' function, which will usually crash the program.
internalError :: HasCallStack => Builder -> a
internalError :: Builder -> a
internalError Builder
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ Builder -> [Char]
forall b. FromBuilder b => Builder -> b
fmt (Builder -> [Char]) -> Builder -> [Char]
forall a b. (a -> b) -> a -> b
$ Builder
"INTERNAL ERROR: "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Builder
msg

isInternalErrorMsg :: String -> Bool
isInternalErrorMsg :: [Char] -> Bool
isInternalErrorMsg [Char]
msg = [Char]
"INTERNAL ERROR" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
msg

-- | Take the first 'Just' from a list of 'Maybe', or die trying.
-- There is no alternative.
tina :: HasCallStack => Builder -> [Maybe a] -> a
tina :: Builder -> [Maybe a] -> a
tina Builder
msg = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (Builder -> a
forall a. HasCallStack => Builder -> a
internalError Builder
msg) (Maybe a -> a) -> ([Maybe a] -> Maybe a) -> [Maybe a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum

-- | Effectfully modify the state of a state-monad transformer stack.
modifyM  :: forall m s. (Monad m) => (s -> m s) -> StateT s m ()
modifyM :: (s -> m s) -> StateT s m ()
modifyM s -> m s
fn = StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT s m s -> (s -> StateT s m s) -> StateT s m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m s -> StateT s m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m s -> StateT s m s) -> (s -> m s) -> s -> StateT s m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m s
fn StateT s m s -> (s -> StateT s m ()) -> StateT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put

-- | Checks whether or not an invariant holds, by applying the given predicate
--   to the given value.
--
-- If the invariant does not hold (indicated by the predicate function
-- returning 'False'), throws an error with the specified message.
--
-- >>> invariant "not empty" [1,2,3] (not . null)
-- [1, 2, 3]
--
-- >>> invariant "not empty" [] (not . null)
-- *** Exception: not empty
invariant
    :: HasCallStack
    => String
        -- ^ The message
    -> a
        -- ^ The value to test
    -> (a -> Bool)
        -- ^ The predicate
    -> a
invariant :: [Char] -> a -> (a -> Bool) -> a
invariant [Char]
msg a
a a -> Bool
predicate = if a -> Bool
predicate a
a then a
a else [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
msg

-- | Tests whether an 'Exception' was caused by 'internalError'.
isInternalError :: ErrorCall -> Maybe String
isInternalError :: ErrorCall -> Maybe [Char]
isInternalError (ErrorCall -> [Char]
forall e. Exception e => e -> [Char]
displayException -> [Char]
msg)
    | [Char] -> Bool
isInternalErrorMsg [Char]
msg = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
msg
    | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

-- | Evaluates a pure expression to WHNF and handles any occurrence of
-- 'internalError'.
--
-- This is intended for use in testing. Don't use this in application code --
-- that's what normal IO exceptions are for.
tryInternalError :: MonadUnliftIO m => a -> m (Either String a)
tryInternalError :: a -> m (Either [Char] a)
tryInternalError = (ErrorCall -> Maybe [Char]) -> m a -> m (Either [Char] a)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust ErrorCall -> Maybe [Char]
isInternalError (m a -> m (Either [Char] a))
-> (a -> m a) -> a -> m (Either [Char] a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate

{-------------------------------------------------------------------------------
                               Formatting helpers
-------------------------------------------------------------------------------}

-- | A polymorphic wrapper type with a custom show instance to display data
-- through 'Buildable' instances.
newtype ShowFmt a = ShowFmt { ShowFmt a -> a
unShowFmt :: a }
    deriving ((forall x. ShowFmt a -> Rep (ShowFmt a) x)
-> (forall x. Rep (ShowFmt a) x -> ShowFmt a)
-> Generic (ShowFmt a)
forall x. Rep (ShowFmt a) x -> ShowFmt a
forall x. ShowFmt a -> Rep (ShowFmt a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ShowFmt a) x -> ShowFmt a
forall a x. ShowFmt a -> Rep (ShowFmt a) x
$cto :: forall a x. Rep (ShowFmt a) x -> ShowFmt a
$cfrom :: forall a x. ShowFmt a -> Rep (ShowFmt a) x
Generic, ShowFmt a -> ShowFmt a -> Bool
(ShowFmt a -> ShowFmt a -> Bool)
-> (ShowFmt a -> ShowFmt a -> Bool) -> Eq (ShowFmt a)
forall a. Eq a => ShowFmt a -> ShowFmt a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowFmt a -> ShowFmt a -> Bool
$c/= :: forall a. Eq a => ShowFmt a -> ShowFmt a -> Bool
== :: ShowFmt a -> ShowFmt a -> Bool
$c== :: forall a. Eq a => ShowFmt a -> ShowFmt a -> Bool
Eq, Eq (ShowFmt a)
Eq (ShowFmt a)
-> (ShowFmt a -> ShowFmt a -> Ordering)
-> (ShowFmt a -> ShowFmt a -> Bool)
-> (ShowFmt a -> ShowFmt a -> Bool)
-> (ShowFmt a -> ShowFmt a -> Bool)
-> (ShowFmt a -> ShowFmt a -> Bool)
-> (ShowFmt a -> ShowFmt a -> ShowFmt a)
-> (ShowFmt a -> ShowFmt a -> ShowFmt a)
-> Ord (ShowFmt a)
ShowFmt a -> ShowFmt a -> Bool
ShowFmt a -> ShowFmt a -> Ordering
ShowFmt a -> ShowFmt a -> ShowFmt a
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
forall a. Ord a => Eq (ShowFmt a)
forall a. Ord a => ShowFmt a -> ShowFmt a -> Bool
forall a. Ord a => ShowFmt a -> ShowFmt a -> Ordering
forall a. Ord a => ShowFmt a -> ShowFmt a -> ShowFmt a
min :: ShowFmt a -> ShowFmt a -> ShowFmt a
$cmin :: forall a. Ord a => ShowFmt a -> ShowFmt a -> ShowFmt a
max :: ShowFmt a -> ShowFmt a -> ShowFmt a
$cmax :: forall a. Ord a => ShowFmt a -> ShowFmt a -> ShowFmt a
>= :: ShowFmt a -> ShowFmt a -> Bool
$c>= :: forall a. Ord a => ShowFmt a -> ShowFmt a -> Bool
> :: ShowFmt a -> ShowFmt a -> Bool
$c> :: forall a. Ord a => ShowFmt a -> ShowFmt a -> Bool
<= :: ShowFmt a -> ShowFmt a -> Bool
$c<= :: forall a. Ord a => ShowFmt a -> ShowFmt a -> Bool
< :: ShowFmt a -> ShowFmt a -> Bool
$c< :: forall a. Ord a => ShowFmt a -> ShowFmt a -> Bool
compare :: ShowFmt a -> ShowFmt a -> Ordering
$ccompare :: forall a. Ord a => ShowFmt a -> ShowFmt a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (ShowFmt a)
Ord)

instance NFData a => NFData (ShowFmt a)

instance Buildable a => Show (ShowFmt a) where
    show :: ShowFmt a -> [Char]
show (ShowFmt a
a) = Builder -> [Char]
forall b. FromBuilder b => Builder -> b
fmt (a -> Builder
forall p. Buildable p => p -> Builder
build a
a)

-- | Map a function to the first element of a list. Does nothing if the list is
-- empty.
mapFirst :: (a -> a) -> [a] -> [a]
mapFirst :: (a -> a) -> [a] -> [a]
mapFirst a -> a
_     [] = []
mapFirst a -> a
fn (a
h:[a]
q) = a -> a
fn a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
q

{-------------------------------------------------------------------------------
                                  HTTP(S) URIs
-------------------------------------------------------------------------------}

uriToText :: URI -> Text
uriToText :: URI -> Text
uriToText URI
uri = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id URI
uri [Char]
""

parseURI :: Text -> Either TextDecodingError URI
parseURI :: Text -> Either TextDecodingError URI
parseURI (Text -> [Char]
T.unpack -> [Char]
uri) = Identity (Either TextDecodingError URI)
-> Either TextDecodingError URI
forall a. Identity a -> a
runIdentity (Identity (Either TextDecodingError URI)
 -> Either TextDecodingError URI)
-> Identity (Either TextDecodingError URI)
-> Either TextDecodingError URI
forall a b. (a -> b) -> a -> b
$ ExceptT TextDecodingError Identity URI
-> Identity (Either TextDecodingError URI)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TextDecodingError Identity URI
 -> Identity (Either TextDecodingError URI))
-> ExceptT TextDecodingError Identity URI
-> Identity (Either TextDecodingError URI)
forall a b. (a -> b) -> a -> b
$ do
    URI
uri' <- [Char] -> Maybe URI
parseAbsoluteURI [Char]
uri Maybe URI
-> TextDecodingError -> ExceptT TextDecodingError Identity URI
forall (m :: * -> *) a e.
Applicative m =>
Maybe a -> e -> ExceptT e m a
??
        ([Char] -> TextDecodingError
TextDecodingError [Char]
"Not a valid absolute URI.")
    let res :: Either [Char] URI
res = case URI
uri' of
            (URI {Maybe URIAuth
uriAuthority :: URI -> Maybe URIAuth
uriAuthority :: Maybe URIAuth
uriAuthority, [Char]
uriScheme :: [Char]
uriScheme :: URI -> [Char]
uriScheme, [Char]
uriPath :: URI -> [Char]
uriPath :: [Char]
uriPath, [Char]
uriQuery :: [Char]
uriQuery :: URI -> [Char]
uriQuery, [Char]
uriFragment :: URI -> [Char]
uriFragment :: [Char]
uriFragment})
                | [Char]
uriScheme [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]
"http:", [Char]
"https:"] ->
                    [Char] -> Either [Char] URI
forall a b. a -> Either a b
Left [Char]
"Not a valid URI scheme, only http/https is supported."
                | Maybe URIAuth -> Bool
forall a. Maybe a -> Bool
isNothing Maybe URIAuth
uriAuthority ->
                    [Char] -> Either [Char] URI
forall a b. a -> Either a b
Left [Char]
"URI must contain a domain part."
                | Bool -> Bool
not (([Char]
uriPath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" Bool -> Bool -> Bool
|| [Char]
uriPath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"/")
                Bool -> Bool -> Bool
&& [Char]
uriQuery [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" Bool -> Bool -> Bool
&& [Char]
uriFragment [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"") ->
                    [Char] -> Either [Char] URI
forall a b. a -> Either a b
Left [Char]
"URI must not contain a path/query/fragment."
            URI
_ -> URI -> Either [Char] URI
forall a b. b -> Either a b
Right URI
uri'
    ([Char] -> ExceptT TextDecodingError Identity URI)
-> (URI -> ExceptT TextDecodingError Identity URI)
-> Either [Char] URI
-> ExceptT TextDecodingError Identity URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TextDecodingError -> ExceptT TextDecodingError Identity URI
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (TextDecodingError -> ExceptT TextDecodingError Identity URI)
-> ([Char] -> TextDecodingError)
-> [Char]
-> ExceptT TextDecodingError Identity URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> TextDecodingError
TextDecodingError) URI -> ExceptT TextDecodingError Identity URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [Char] URI
res