module Hackage.Security.Client.Verify (
    -- * Verification monad
    Verify -- opaque
  , runVerify
  , acquire
  , ifVerified
    -- * Specific resources
  , openTempFile
    -- * Re-exports
  , liftIO
  ) where

import MyPrelude
import Control.Exception
import Control.Monad (join, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Data.IORef

import Hackage.Security.Util.IO
import Hackage.Security.Util.Path

{-------------------------------------------------------------------------------
  Verification monad
-------------------------------------------------------------------------------}

type Finaliser = IO ()
type Cleanup   = IO ()

-- | Verification monad
--
-- The verification monad is similar to 'ResourceT' in intent, in that we can
-- register handlers to be run to release resources. Unlike 'ResourceT',
-- however, we maintain _two_ handlers: a cleanup handler which is run  whether
-- or not verification succeeds, and a finalisation handler which is run only if
-- verification succeeds.
--
-- * Cleanup handlers are registered using 'acquire', and are guaranteed to run
--   just before the computation terminates (after the finalisation handler).
-- * The finalisation handlers are run only when verification succeeds, and can
--   be registered with 'ifVerified'. Finalisation can be used for instance to
--   update the local cache (which should only happen if verification is
--   successful).
newtype Verify a = Verify {
    forall a. Verify a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
unVerify :: ReaderT (IORef Cleanup, IORef Finaliser) IO a
  }
  deriving (forall a b. a -> Verify b -> Verify a
forall a b. (a -> b) -> Verify a -> Verify b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Verify b -> Verify a
$c<$ :: forall a b. a -> Verify b -> Verify a
fmap :: forall a b. (a -> b) -> Verify a -> Verify b
$cfmap :: forall a b. (a -> b) -> Verify a -> Verify b
Functor, Functor Verify
forall a. a -> Verify a
forall a b. Verify a -> Verify b -> Verify a
forall a b. Verify a -> Verify b -> Verify b
forall a b. Verify (a -> b) -> Verify a -> Verify b
forall a b c. (a -> b -> c) -> Verify a -> Verify b -> Verify c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Verify a -> Verify b -> Verify a
$c<* :: forall a b. Verify a -> Verify b -> Verify a
*> :: forall a b. Verify a -> Verify b -> Verify b
$c*> :: forall a b. Verify a -> Verify b -> Verify b
liftA2 :: forall a b c. (a -> b -> c) -> Verify a -> Verify b -> Verify c
$cliftA2 :: forall a b c. (a -> b -> c) -> Verify a -> Verify b -> Verify c
<*> :: forall a b. Verify (a -> b) -> Verify a -> Verify b
$c<*> :: forall a b. Verify (a -> b) -> Verify a -> Verify b
pure :: forall a. a -> Verify a
$cpure :: forall a. a -> Verify a
Applicative, Applicative Verify
forall a. a -> Verify a
forall a b. Verify a -> Verify b -> Verify b
forall a b. Verify a -> (a -> Verify b) -> Verify b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Verify a
$creturn :: forall a. a -> Verify a
>> :: forall a b. Verify a -> Verify b -> Verify b
$c>> :: forall a b. Verify a -> Verify b -> Verify b
>>= :: forall a b. Verify a -> (a -> Verify b) -> Verify b
$c>>= :: forall a b. Verify a -> (a -> Verify b) -> Verify b
Monad, Monad Verify
forall a. IO a -> Verify a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Verify a
$cliftIO :: forall a. IO a -> Verify a
MonadIO)

-- | Run an action in the 'Verify' monad
runVerify :: (Finaliser -> Finaliser) -> Verify a -> IO a
runVerify :: forall a. (Cleanup -> Cleanup) -> Verify a -> IO a
runVerify Cleanup -> Cleanup
modifyFinaliser Verify a
v = do
    IORef Cleanup
rCleanup   <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IORef Cleanup
rFinaliser <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
      Either SomeException a
ma <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Verify a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
unVerify Verify a
v) (IORef Cleanup
rCleanup, IORef Cleanup
rFinaliser)
      case Either SomeException a
ma of
        Left SomeException
ex -> do forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Cleanup
rCleanup
                      forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
        Right a
a -> do Cleanup -> Cleanup
modifyFinaliser forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Cleanup
rFinaliser
                      forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Cleanup
rCleanup
                      forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Acquire a resource and register the corresponding cleanup handler
--
-- NOTE: Resource acquisition happens with exceptions masked. If it is important
-- that the resource acquistion can be timed out (or receive other kinds of
-- asynchronous exceptions), you will need to use an interruptible operation.
-- See <http://www.well-typed.com/blog/2014/08/asynchronous-exceptions/> for
-- details.
acquire :: IO a -> (a -> IO ()) -> Verify a
acquire :: forall a. IO a -> (a -> Cleanup) -> Verify a
acquire IO a
get a -> Cleanup
release = forall a. ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
Verify forall a b. (a -> b) -> a -> b
$ do
    (IORef Cleanup
rCleanup, IORef Cleanup
_rFinaliser) <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
      a
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
get
      forall a. IORef a -> (a -> a) -> Cleanup
modifyIORef IORef Cleanup
rCleanup (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Cleanup
release a
a)
      forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Register an action to be run only if verification succeeds
ifVerified :: IO () -> Verify ()
ifVerified :: Cleanup -> Verify ()
ifVerified Cleanup
handler = forall a. ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
Verify forall a b. (a -> b) -> a -> b
$ do
    (IORef Cleanup
_rCleanup, IORef Cleanup
rFinaliser) <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> Cleanup
modifyIORef IORef Cleanup
rFinaliser (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Cleanup
handler)

{-------------------------------------------------------------------------------
  Specific resources
-------------------------------------------------------------------------------}

-- | Create a short-lived temporary file
--
-- Creates the directory where the temp file should live if it does not exist.
openTempFile :: FsRoot root
             => Path root  -- ^ Temp directory
             -> String     -- ^ Template
             -> Verify (Path Absolute, Handle)
openTempFile :: forall root.
FsRoot root =>
Path root -> String -> Verify (Path Absolute, Handle)
openTempFile Path root
tmpDir String
template =
    forall a. IO a -> (a -> Cleanup) -> Verify a
acquire IO (Path Absolute, Handle)
createTempFile (Path Absolute, Handle) -> Cleanup
closeAndDelete
  where
    createTempFile :: IO (Path Absolute, Handle)
    createTempFile :: IO (Path Absolute, Handle)
createTempFile = do
      forall root. FsRoot root => Bool -> Path root -> Cleanup
createDirectoryIfMissing Bool
True Path root
tmpDir
      forall root.
FsRoot root =>
Path root -> String -> IO (Path Absolute, Handle)
openTempFile' Path root
tmpDir String
template

    closeAndDelete :: (Path Absolute, Handle) -> IO ()
    closeAndDelete :: (Path Absolute, Handle) -> Cleanup
closeAndDelete (Path Absolute
fp, Handle
h) = do
      Handle -> Cleanup
hClose Handle
h
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
handleDoesNotExist forall a b. (a -> b) -> a -> b
$ forall root. FsRoot root => Path root -> Cleanup
removeFile Path Absolute
fp