{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Network.IPFS.Git.RemoteHelper.Trans
( Logger (..)
, defaultLogger
, Env
, newEnv
, envVerbosity
, envDryRun
, envOptions
, envIpfsOptions
, envGit
, envClient
, envIpfsRoot
, envLobs
, RemoteHelper
, RemoteHelperT
, runRemoteHelper
, runRemoteHelperT
, DisplayError (..)
, RemoteHelperError
, errError
, errCallStack
, throwRH
, catchRH
, mapError
, liftEitherRH
, concurrently
, concurrently_
, forConcurrently_
, forConcurrently
, logInfo
, logDebug
, logError
, renderSourceLoc
)
where
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Exception.Safe
import qualified Control.Lens as Lens
import Control.Monad.Except
import Control.Monad.Primitive
import Control.Monad.Reader
import qualified Data.Aeson.Lens as Lens
import Data.Bifunctor (first)
import Data.HashMap.Strict (HashMap)
import Data.IORef (IORef, newIORef, readIORef)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Stack
( CallStack
, HasCallStack
, callStack
, freezeCallStack
, getCallStack
, srcLocFile
, srcLocStartLine
)
import System.IO (stderr)
import Data.Git (Git)
import Data.Git.Monad (GitMonad(..))
import Data.Git.Ref (SHA1)
import Data.Git.Storage (findRepo, openRepo)
import Network.HTTP.Client
( defaultManagerSettings
, managerResponseTimeout
, newManager
, responseTimeoutNone
)
import Servant.Client.Streaming (mkClientEnv)
import qualified Servant.Client.Streaming as Servant
import Data.IPLD.CID (CID, cidFromText)
import Network.IPFS.API (ApiV0NameResolve)
import Network.IPFS.Git.RemoteHelper.Internal (note)
import Network.IPFS.Git.RemoteHelper.Options
data Logger = Logger
{ _logInfo :: Text -> IO ()
, _logDebug :: Text -> IO ()
, _logError :: Text -> IO ()
}
data Env = Env
{ envVerbosity :: IORef Word
, envDryRun :: IORef Bool
, envOptions :: Options
, envIpfsOptions :: IpfsOptions
, envLogger :: Logger
, envGit :: Git SHA1
, envGitMutex :: MVar ()
, envClient :: Servant.ClientEnv
, envIpfsRoot :: CID
, envLobs :: MVar (Maybe (HashMap CID CID))
}
class DisplayError a where
displayError :: a -> Text
data RemoteHelperError a = RemoteHelperError
{ errCallStack :: CallStack
, errError :: a
} deriving Show
instance
(Show a, Typeable a, DisplayError a)
=> Exception (RemoteHelperError a)
where
displayException = Text.unpack . displayError
instance DisplayError a => DisplayError (RemoteHelperError a) where
displayError e =
displayError (errError e) <> " " <> renderSourceLoc (errCallStack e)
type RemoteHelper e = RemoteHelperT e IO
newtype RemoteHelperT e m a = RemoteHelperT
{ unRemoteHelperT :: ExceptT (RemoteHelperError e) (ReaderT Env m) a
} deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadReader Env
, MonadError (RemoteHelperError e)
, MonadThrow
, MonadCatch
, MonadMask
)
instance MonadTrans (RemoteHelperT e) where
lift = RemoteHelperT . lift . lift
{-# INLINE lift #-}
instance PrimMonad m => PrimMonad (RemoteHelperT e m) where
type PrimState (RemoteHelperT e m) = PrimState m
primitive = lift . primitive
{-# INLINE primitive #-}
instance MonadIO m => GitMonad (RemoteHelperT e m) where
getGit = asks envGit
liftGit f = do
lck <- asks envGitMutex
liftIO . withMVar lck . const $ f
{-# INLINE getGit #-}
{-# INLINE liftGit #-}
remoteHelperError :: CallStack -> a -> RemoteHelperError a
remoteHelperError cs e = RemoteHelperError
{ errCallStack = cs
, errError = e
}
throwRH :: (Monad m, HasCallStack) => e -> RemoteHelperT e m a
throwRH = throwError . remoteHelperError (freezeCallStack callStack)
catchRH
:: Monad m
=> RemoteHelperT e m a
-> (e -> RemoteHelperT e m a)
-> RemoteHelperT e m a
catchRH ma f = catchError ma (f . errError)
mapError
:: Monad m
=> (e -> e')
-> RemoteHelperT e m a
-> RemoteHelperT e' m a
mapError f (RemoteHelperT ma) =
RemoteHelperT $ flip withExceptT ma $ \e ->
e { errError = f (errError e) }
liftEitherRH :: (Monad m, HasCallStack) => Either e a -> RemoteHelperT e m a
liftEitherRH =
liftEither . first (remoteHelperError (freezeCallStack callStack))
concurrently
:: (Show e, Typeable e, DisplayError e)
=> RemoteHelperT e IO a
-> RemoteHelperT e IO b
-> RemoteHelperT e IO (a, b)
concurrently left right = do
env <- ask
liftIO $ Async.concurrently
(either throwM pure =<< runRemoteHelperT env left)
(either throwM pure =<< runRemoteHelperT env right)
concurrently_
:: (Show e, Typeable e, DisplayError e)
=> RemoteHelperT e IO a
-> RemoteHelperT e IO b
-> RemoteHelperT e IO ()
concurrently_ left right = do
env <- ask
liftIO $ Async.concurrently_
(either throwM pure =<< runRemoteHelperT env left)
(either throwM pure =<< runRemoteHelperT env right)
forConcurrently_
:: ( Foldable t
, Show e
, Typeable e
, DisplayError e
)
=> t a
-> (a -> RemoteHelperT e IO b)
-> RemoteHelperT e IO ()
forConcurrently_ xs f = do
env <- ask
liftIO $
Async.forConcurrently_ xs $ \x ->
either throwM pure =<< runRemoteHelperT env (f x)
forConcurrently
:: ( Traversable t
, Show e
, Typeable e
, DisplayError e
)
=> t a
-> (a -> RemoteHelperT e IO b)
-> RemoteHelperT e IO (t b)
forConcurrently xs f = do
env <- ask
liftIO $
Async.forConcurrently xs $ \x ->
either throwM pure =<< runRemoteHelperT env (f x)
logInfo :: MonadIO m => Text -> RemoteHelperT e m ()
logInfo msg = do
out <- asks $ _logInfo . envLogger
v <- liftIO . readIORef =<< asks envVerbosity
when (v > 0) $
liftIO $ out msg
logDebug :: (HasCallStack, MonadIO m) => Text -> RemoteHelperT e m ()
logDebug msg = do
out <- asks $ _logDebug . envLogger
v <- liftIO . readIORef =<< asks envVerbosity
when (v > 1) $
liftIO . out $ msg <> renderSourceLoc callStack
logError :: (HasCallStack, MonadIO m) => Text -> RemoteHelperT e m ()
logError msg = do
out <- asks $ _logError . envLogger
liftIO . out $ msg <> renderSourceLoc callStack
renderSourceLoc :: CallStack -> Text
renderSourceLoc cs =
case getCallStack cs of
((_, loc) : _) ->
" (" <> Text.pack (srcLocFile loc)
<> ":"
<> Text.pack (show (srcLocStartLine loc))
<> ")"
_ ->
" (<unknown>)"
defaultLogger :: Logger
defaultLogger = Logger out out out
where
out = Text.hPutStrLn stderr
newEnv :: HasCallStack => Logger -> Options -> IpfsOptions -> IO Env
newEnv envLogger envOptions envIpfsOptions = do
envVerbosity <- newIORef 1
envDryRun <- newIORef False
envGit <- findRepo >>= openRepo
envGitMutex <- newMVar ()
envLobs <- newMVar Nothing
envClient <-
flip mkClientEnv (ipfsApiUrl envIpfsOptions)
<$> newManager defaultManagerSettings
{ managerResponseTimeout = responseTimeoutNone }
envIpfsRoot <-
case remoteUrlIpfsPath (optRemoteUrl envOptions) of
IpfsPathIpfs cid -> pure cid
IpfsPathIpns name -> do
_logInfo envLogger $ "Resolving IPNS name " <> name
res <-
flip Servant.runClientM envClient $
ipfsNameResolve name
(Just True)
Nothing
Nothing
Nothing
case res of
Left e -> throwM e
Right v -> either throwString pure $ do
path <-
note "ipfsNameResolve: expected 'Path' key" $
Lens.firstOf (Lens.key "Path" . Lens._String) v
cidFromText
. fromMaybe path
$ Text.stripPrefix "/ipfs/" path
pure Env {..}
where
ipfsNameResolve = Servant.client (Proxy @ApiV0NameResolve)
runRemoteHelperT
:: Env
-> RemoteHelperT e m a
-> m (Either (RemoteHelperError e) a)
runRemoteHelperT r = flip runReaderT r . runExceptT . unRemoteHelperT
runRemoteHelper :: Env -> RemoteHelper e a -> IO (Either (RemoteHelperError e) a)
runRemoteHelper = runRemoteHelperT