{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE RoleAnnotations     #-}

{-# OPTIONS_GHC -Wno-unused-binds #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Checked exceptions
module Hackage.Security.Util.Checked (
    Throws
  , unthrow
    -- ** Base exceptions
  , throwChecked
  , catchChecked
  , handleChecked
  , tryChecked
  , checkIO
  , throwUnchecked
  , internalError
  ) where

import Prelude
import Control.Exception (Exception, IOException)
import qualified Control.Exception as Base
import Data.Typeable (Typeable)

import GHC.Prim (coerce)

{-------------------------------------------------------------------------------
  Basic infrastructure
-------------------------------------------------------------------------------}

-- | Checked exceptions
class Throws e where

type role Throws representational

unthrow :: forall a e proxy . proxy e -> (Throws e => a) -> a
unthrow :: forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
unthrow proxy e
_ Throws e => a
x = Wrap (Catch e) a -> Throws (Catch e) => a
forall e a. Wrap e a -> Throws e => a
unWrap (Wrap e a -> Wrap (Catch e) a
forall e a. Wrap e a -> Wrap (Catch e) a
coerceWrap ((Throws e => a) -> Wrap e a
forall e a. (Throws e => a) -> Wrap e a
Wrap a
Throws e => a
x :: Wrap e a))

{-------------------------------------------------------------------------------
  Base exceptions
-------------------------------------------------------------------------------}

-- | Determine if an exception is asynchronous, based on its type.
isAsync :: Exception e => e -> Bool
isAsync :: forall e. Exception e => e -> Bool
isAsync e
e =
  case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
Base.fromException (SomeException -> Maybe SomeAsyncException)
-> SomeException -> Maybe SomeAsyncException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
Base.toException e
e of
    Just Base.SomeAsyncException{} -> Bool
True
    Maybe SomeAsyncException
Nothing -> Bool
False

-- | 'Base.catch', but immediately rethrows asynchronous exceptions
-- (as determined by 'isAsync').
catchSync :: Exception e => IO a -> (e -> IO a) -> IO a
catchSync :: forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catchSync IO a
act e -> IO a
onErr = IO a
act IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Base.catch` \e
e ->
  if e -> Bool
forall e. Exception e => e -> Bool
isAsync e
e
    then e -> IO a
forall e a. Exception e => e -> IO a
Base.throwIO e
e
    else e -> IO a
onErr e
e

-- | Wraps up an async exception as a synchronous exception.
newtype SyncException = SyncException Base.SomeException
  deriving (Int -> SyncException -> ShowS
[SyncException] -> ShowS
SyncException -> String
(Int -> SyncException -> ShowS)
-> (SyncException -> String)
-> ([SyncException] -> ShowS)
-> Show SyncException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SyncException -> ShowS
showsPrec :: Int -> SyncException -> ShowS
$cshow :: SyncException -> String
show :: SyncException -> String
$cshowList :: [SyncException] -> ShowS
showList :: [SyncException] -> ShowS
Show, Typeable)
instance Exception SyncException

-- | Throw a checked exception
throwChecked :: (Exception e, Throws e) => e -> IO a
throwChecked :: forall e a. (Exception e, Throws e) => e -> IO a
throwChecked e
e
  | e -> Bool
forall e. Exception e => e -> Bool
isAsync e
e = SyncException -> IO a
forall e a. Exception e => e -> IO a
Base.throwIO (SyncException -> IO a) -> SyncException -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> SyncException
SyncException (SomeException -> SyncException) -> SomeException -> SyncException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
Base.toException e
e
  | Bool
otherwise = e -> IO a
forall e a. Exception e => e -> IO a
Base.throwIO e
e

-- | Catch a checked exception
catchChecked :: forall a e. Exception e
             => (Throws e => IO a) -> (e -> IO a) -> IO a
catchChecked :: forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
catchChecked Throws e => IO a
act = IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catchSync (Proxy e -> (Throws e => IO a) -> IO a
forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
unthrow (Proxy e
forall a. Proxy a
Proxy :: Proxy e) IO a
Throws e => IO a
act)

-- | 'catchChecked' with the arguments reversed
handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked :: forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked e -> IO a
act Throws e => IO a
handler = (Throws e => IO a) -> (e -> IO a) -> IO a
forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
catchChecked IO a
Throws e => IO a
handler e -> IO a
act

-- | Like 'try', but for checked exceptions
tryChecked :: Exception e => (Throws e => IO a) -> IO (Either e a)
tryChecked :: forall e a. Exception e => (Throws e => IO a) -> IO (Either e a)
tryChecked Throws e => IO a
act = (Throws e => IO (Either e a))
-> (e -> IO (Either e a)) -> IO (Either e a)
forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
catchChecked (a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> IO a -> IO (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
Throws e => IO a
act) (Either e a -> IO (Either e a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> IO (Either e a))
-> (e -> Either e a) -> e -> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)

-- | Rethrow IO exceptions as checked exceptions
checkIO :: Throws IOException => IO a -> IO a
checkIO :: forall a. Throws IOException => IO a -> IO a
checkIO = (IOException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Base.handle ((IOException -> IO a) -> IO a -> IO a)
-> (IOException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \(IOException
ex :: IOException) -> IOException -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked IOException
ex

-- | Throw an unchecked exception
--
-- This is just an alias for 'throw', but makes it evident that this is a very
-- intentional use of an unchecked exception.
throwUnchecked :: Exception e => e -> IO a
throwUnchecked :: forall e a. Exception e => e -> IO a
throwUnchecked = e -> IO a
forall e a. Exception e => e -> IO a
Base.throwIO

-- | Variation on 'throwUnchecked' for internal errors
internalError :: String -> IO a
internalError :: forall a. String -> IO a
internalError = IOException -> IO a
forall e a. Exception e => e -> IO a
throwUnchecked (IOException -> IO a) -> (String -> IOException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOException
userError

{-------------------------------------------------------------------------------
  Auxiliary definitions (not exported)
-------------------------------------------------------------------------------}

-- | Wrap an action that may throw a checked exception
--
-- This is used internally in 'unthrow' to avoid impredicative
-- instantiation of the type of 'coerce'/'unsafeCoerce'.
newtype Wrap e a = Wrap { forall e a. Wrap e a -> Throws e => a
unWrap :: Throws e => a }

coerceWrap :: Wrap e a -> Wrap (Catch e) a
coerceWrap :: forall e a. Wrap e a -> Wrap (Catch e) a
coerceWrap = Wrap e a -> Wrap (Catch e) a
forall a b. Coercible a b => a -> b
coerce

data Proxy a = Proxy

newtype Catch a = Catch a
instance Throws (Catch e) where