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

import Prelude
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 -> b) -> Verify a -> Verify b)
-> (forall a b. a -> Verify b -> Verify a) -> Functor Verify
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
$cfmap :: forall a b. (a -> b) -> Verify a -> Verify b
fmap :: forall a b. (a -> b) -> Verify a -> Verify b
$c<$ :: forall a b. a -> Verify b -> Verify a
<$ :: forall a b. a -> Verify b -> Verify a
Functor, Functor Verify
Functor Verify =>
(forall a. a -> Verify a)
-> (forall a b. Verify (a -> b) -> Verify a -> Verify b)
-> (forall a b c.
    (a -> b -> c) -> Verify a -> Verify b -> Verify c)
-> (forall a b. Verify a -> Verify b -> Verify b)
-> (forall a b. Verify a -> Verify b -> Verify a)
-> Applicative 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
$cpure :: forall a. a -> Verify a
pure :: forall a. a -> Verify a
$c<*> :: forall a b. Verify (a -> b) -> Verify a -> Verify b
<*> :: forall a b. Verify (a -> b) -> Verify a -> Verify b
$cliftA2 :: forall a b c. (a -> b -> c) -> Verify a -> Verify b -> Verify c
liftA2 :: forall a b c. (a -> b -> c) -> Verify a -> Verify b -> Verify c
$c*> :: forall a b. Verify a -> Verify b -> Verify b
*> :: forall a b. Verify a -> Verify b -> Verify b
$c<* :: forall a b. Verify a -> Verify b -> Verify a
<* :: forall a b. Verify a -> Verify b -> Verify a
Applicative, Applicative Verify
Applicative Verify =>
(forall a b. Verify a -> (a -> Verify b) -> Verify b)
-> (forall a b. Verify a -> Verify b -> Verify b)
-> (forall a. a -> Verify a)
-> Monad 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
$c>>= :: forall a b. Verify a -> (a -> Verify b) -> Verify b
>>= :: forall a b. Verify a -> (a -> Verify b) -> Verify b
$c>> :: forall a b. Verify a -> Verify b -> Verify b
>> :: forall a b. Verify a -> Verify b -> Verify b
$creturn :: forall a. a -> Verify a
return :: forall a. a -> Verify a
Monad, Monad Verify
Monad Verify => (forall a. IO a -> Verify a) -> MonadIO Verify
forall a. IO a -> Verify a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Verify a
liftIO :: 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   <- Cleanup -> IO (IORef Cleanup)
forall a. a -> IO (IORef a)
newIORef (Cleanup -> IO (IORef Cleanup)) -> Cleanup -> IO (IORef Cleanup)
forall a b. (a -> b) -> a -> b
$ () -> Cleanup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IORef Cleanup
rFinaliser <- Cleanup -> IO (IORef Cleanup)
forall a. a -> IO (IORef a)
newIORef (Cleanup -> IO (IORef Cleanup)) -> Cleanup -> IO (IORef Cleanup)
forall a b. (a -> b) -> a -> b
$ () -> Cleanup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
      Either SomeException a
ma <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ReaderT (IORef Cleanup, IORef Cleanup) IO a
-> (IORef Cleanup, IORef Cleanup) -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Verify a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
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 IO Cleanup -> Cleanup
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO Cleanup -> Cleanup) -> IO Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ IORef Cleanup -> IO Cleanup
forall a. IORef a -> IO a
readIORef IORef Cleanup
rCleanup
                      SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
        Right a
a -> do Cleanup -> Cleanup
modifyFinaliser (Cleanup -> Cleanup) -> Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ IO Cleanup -> Cleanup
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO Cleanup -> Cleanup) -> IO Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ IORef Cleanup -> IO Cleanup
forall a. IORef a -> IO a
readIORef IORef Cleanup
rFinaliser
                      IO Cleanup -> Cleanup
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO Cleanup -> Cleanup) -> IO Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ IORef Cleanup -> IO Cleanup
forall a. IORef a -> IO a
readIORef IORef Cleanup
rCleanup
                      a -> IO a
forall a. a -> IO a
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 = ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
forall a. ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
Verify (ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a)
-> ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
forall a b. (a -> b) -> a -> b
$ do
    (IORef Cleanup
rCleanup, IORef Cleanup
_rFinaliser) <- ReaderT
  (IORef Cleanup, IORef Cleanup) IO (IORef Cleanup, IORef Cleanup)
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
forall a. IO a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a)
-> IO a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      a
a <- IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
get
      IORef Cleanup -> (Cleanup -> Cleanup) -> Cleanup
forall a. IORef a -> (a -> a) -> Cleanup
modifyIORef IORef Cleanup
rCleanup (Cleanup -> Cleanup -> Cleanup
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Cleanup
release a
a)
      a -> IO a
forall a. a -> IO 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 = ReaderT (IORef Cleanup, IORef Cleanup) IO () -> Verify ()
forall a. ReaderT (IORef Cleanup, IORef Cleanup) IO a -> Verify a
Verify (ReaderT (IORef Cleanup, IORef Cleanup) IO () -> Verify ())
-> ReaderT (IORef Cleanup, IORef Cleanup) IO () -> Verify ()
forall a b. (a -> b) -> a -> b
$ do
    (IORef Cleanup
_rCleanup, IORef Cleanup
rFinaliser) <- ReaderT
  (IORef Cleanup, IORef Cleanup) IO (IORef Cleanup, IORef Cleanup)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Cleanup -> ReaderT (IORef Cleanup, IORef Cleanup) IO ()
forall a. IO a -> ReaderT (IORef Cleanup, IORef Cleanup) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Cleanup -> ReaderT (IORef Cleanup, IORef Cleanup) IO ())
-> Cleanup -> ReaderT (IORef Cleanup, IORef Cleanup) IO ()
forall a b. (a -> b) -> a -> b
$ IORef Cleanup -> (Cleanup -> Cleanup) -> Cleanup
forall a. IORef a -> (a -> a) -> Cleanup
modifyIORef IORef Cleanup
rFinaliser (Cleanup -> Cleanup -> Cleanup
forall a b. IO a -> IO b -> IO b
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 =
    IO (Path Absolute, Handle)
-> ((Path Absolute, Handle) -> Cleanup)
-> Verify (Path Absolute, Handle)
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
      Bool -> Path root -> Cleanup
forall root. FsRoot root => Bool -> Path root -> Cleanup
createDirectoryIfMissing Bool
True Path root
tmpDir
      Path root -> String -> IO (Path Absolute, Handle)
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
      IO (Maybe ()) -> Cleanup
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> Cleanup) -> IO (Maybe ()) -> Cleanup
forall a b. (a -> b) -> a -> b
$ Cleanup -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
handleDoesNotExist (Cleanup -> IO (Maybe ())) -> Cleanup -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Path Absolute -> Cleanup
forall root. FsRoot root => Path root -> Cleanup
removeFile Path Absolute
fp