{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Neptune.Client where
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.Event as E (new, set, waitTimeout)
import Control.Exception (AsyncException (UserInterrupt),
asyncExceptionFromException, try)
import Control.Lens (bimapping, each, filtered, (<&>),
(^.), (^..))
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Text.Lens (packed)
import Data.Time.Clock (getCurrentTime)
import qualified Data.UUID as UUID (toText)
import Data.UUID.V4 as UUID (nextRandom)
import qualified Network.HTTP.Client as NH
import qualified Network.HTTP.Client.TLS as NH
import RIO hiding (Lens', try, (^.), (^..))
import qualified RIO.HashMap as M
import qualified RIO.Text as T
import System.Environment (getArgs, getEnvironment)
import System.Envy (decodeEnv)
import System.Posix.Signals (Handler (Catch), installHandler,
keyboardSignal)
import Neptune.AbortHandler (AbortException (..), abortListener)
import qualified Neptune.Backend.API as NBAPI
import Neptune.Backend.Client
import Neptune.Backend.Core
import Neptune.Backend.MimeTypes
import Neptune.Backend.Model hiding (Experiment, Parameter)
import Neptune.Backend.ModelLens
import Neptune.Channel
import Neptune.OAuth
import Neptune.Session
import Neptune.Utils
data Parameter = ExperimentParamS Text Text
| ExperimentParamD Text Double
createExperiment :: HasCallStack
=> NeptuneSession
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> IO Experiment
createExperiment :: NeptuneSession
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> IO Experiment
createExperiment session :: NeptuneSession
session@NeptuneSession{ThreadId
MVar OAuth2Session
Manager
NeptuneBackendConfig
ProjectWithRoleDTO
ClientToken
Dispatcher
_neptune_dispatch :: NeptuneSession -> Dispatcher
_neptune_project :: NeptuneSession -> ProjectWithRoleDTO
_neptune_oauth2_refresh :: NeptuneSession -> ThreadId
_neptune_oauth2 :: NeptuneSession -> MVar OAuth2Session
_neptune_config :: NeptuneSession -> NeptuneBackendConfig
_neptune_client_token :: NeptuneSession -> ClientToken
_neptune_http_manager :: NeptuneSession -> Manager
_neptune_dispatch :: Dispatcher
_neptune_project :: ProjectWithRoleDTO
_neptune_oauth2_refresh :: ThreadId
_neptune_oauth2 :: MVar OAuth2Session
_neptune_config :: NeptuneBackendConfig
_neptune_client_token :: ClientToken
_neptune_http_manager :: Manager
..} Maybe Text
name Maybe Text
description [Parameter]
params [(Text, Text)]
props [Text]
tags = do
[Parameter]
params <- (Parameter -> IO Parameter) -> [Parameter] -> IO [Parameter]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Parameter -> IO Parameter
_mkParameter [Parameter]
params
Experiment
exp <- NeptuneBackendRequest CreateExperiment MimeJSON Experiment MimeJSON
-> IO Experiment
Dispatcher
_neptune_dispatch (NeptuneBackendRequest
CreateExperiment MimeJSON Experiment MimeJSON
-> IO Experiment)
-> NeptuneBackendRequest
CreateExperiment MimeJSON Experiment MimeJSON
-> IO Experiment
forall a b. (a -> b) -> a -> b
$ ContentType MimeJSON
-> Accept MimeJSON
-> ExperimentCreationParams
-> NeptuneBackendRequest
CreateExperiment MimeJSON Experiment MimeJSON
forall contentType accept.
(Consumes CreateExperiment contentType,
MimeRender contentType ExperimentCreationParams) =>
ContentType contentType
-> Accept accept
-> ExperimentCreationParams
-> NeptuneBackendRequest
CreateExperiment contentType Experiment accept
NBAPI.createExperiment
(MimeJSON -> ContentType MimeJSON
forall a. MimeType a => a -> ContentType a
ContentType MimeJSON
MimeJSON)
(MimeJSON -> Accept MimeJSON
forall a. MimeType a => a -> Accept a
Accept MimeJSON
MimeJSON)
(Text
-> [KeyValueProperty]
-> Text
-> [Parameter]
-> Text
-> Text
-> [Text]
-> ExperimentCreationParams
mkExperimentCreationParams
(ProjectWithRoleDTO
_neptune_project ProjectWithRoleDTO -> Getting Text ProjectWithRoleDTO Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ProjectWithRoleDTO Text
Lens_' ProjectWithRoleDTO Text
projectWithRoleDTOIdL)
(((Text, Text) -> KeyValueProperty)
-> [(Text, Text)] -> [KeyValueProperty]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> KeyValueProperty)
-> (Text, Text) -> KeyValueProperty
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> KeyValueProperty
KeyValueProperty) [(Text, Text)]
props)
Text
""
[Parameter]
params
Text
"command"
(Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"Untitled" Maybe Text
name)
[Text]
tags){ experimentCreationParamsDescription :: Maybe Text
experimentCreationParamsDescription = Maybe Text
description
, experimentCreationParamsAbortable :: Maybe Bool
experimentCreationParamsAbortable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }
let exp_id :: ExperimentId
exp_id = Text -> ExperimentId
ExperimentId (Experiment
exp Experiment -> Getting Text Experiment Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Experiment Text
Lens_' Experiment Text
experimentIdL)
TChan DataPointAny
chan <- IO (TChan DataPointAny)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newTChanIO
TVar (HashMap Text DataChannelAny)
user_channels <- HashMap Text DataChannelAny
-> IO (TVar (HashMap Text DataChannelAny))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO HashMap Text DataChannelAny
forall k v. HashMap k v
M.empty
Event
stop_flag <- IO Event
E.new
Event
transmitter_flag <- IO Event
E.new
let exp :: Experiment
exp = ExperimentId
-> TChan DataPointAny
-> TVar (HashMap Text DataChannelAny)
-> Event
-> Event
-> ThreadId
-> ThreadId
-> Experiment
Experiment ExperimentId
exp_id TChan DataPointAny
chan TVar (HashMap Text DataChannelAny)
user_channels Event
stop_flag Event
transmitter_flag ThreadId
forall a. HasCallStack => a
undefined ThreadId
forall a. HasCallStack => a
undefined
ThreadId
transmitter_thread <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ HasCallStack => NeptuneSession -> Experiment -> IO ()
NeptuneSession -> Experiment -> IO ()
transmitter NeptuneSession
session Experiment
exp
ThreadId
parent_thread <- IO ThreadId
forall (m :: * -> *). MonadIO m => m ThreadId
myThreadId
ThreadId
abort_handler <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ NeptuneSession -> Experiment -> ThreadId -> IO ()
abortListener NeptuneSession
session Experiment
exp ThreadId
parent_thread
Experiment -> IO Experiment
forall (m :: * -> *) a. Monad m => a -> m a
return Experiment
exp {_exp_transmitter :: ThreadId
_exp_transmitter = ThreadId
transmitter_thread, _exp_abort_handler :: ThreadId
_exp_abort_handler = ThreadId
abort_handler}
where
_mkParameter :: Parameter -> IO Parameter
_mkParameter (ExperimentParamS Text
name Text
value) = do
Text
_id <- UUID -> Text
UUID.toText (UUID -> Text) -> IO UUID -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom
Parameter -> IO Parameter
forall (m :: * -> *) a. Monad m => a -> m a
return (Parameter -> IO Parameter) -> Parameter -> IO Parameter
forall a b. (a -> b) -> a -> b
$ Text -> ParameterTypeEnum -> Text -> Text -> Parameter
mkParameter Text
name ParameterTypeEnum
ParameterTypeEnum'String Text
_id Text
value
_mkParameter (ExperimentParamD Text
name Double
value) = do
Text
_id <- UUID -> Text
UUID.toText (UUID -> Text) -> IO UUID -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom
Parameter -> IO Parameter
forall (m :: * -> *) a. Monad m => a -> m a
return (Parameter -> IO Parameter) -> Parameter -> IO Parameter
forall a b. (a -> b) -> a -> b
$ Text -> ParameterTypeEnum -> Text -> Text -> Parameter
mkParameter Text
name ParameterTypeEnum
ParameterTypeEnum'Double Text
_id (Double -> Text
forall a. Show a => a -> Text
tshow Double
value)
nlog :: (HasCallStack, NeptDataType a)
=> Experiment
-> Text
-> a
-> IO ()
nlog :: Experiment -> Text -> a -> IO ()
nlog Experiment
exp Text
name a
value = do
UTCTime
now <- IO UTCTime
getCurrentTime
let chan :: TChan DataPointAny
chan = Experiment
exp Experiment
-> Getting (TChan DataPointAny) Experiment (TChan DataPointAny)
-> TChan DataPointAny
forall s a. s -> Getting a s a -> a
^. Getting (TChan DataPointAny) Experiment (TChan DataPointAny)
Lens' Experiment (TChan DataPointAny)
exp_outbound_q
dat :: DataPointAny
dat = DataPoint a -> DataPointAny
forall a. NeptDataType a => DataPoint a -> DataPointAny
DataPointAny (DataPoint a -> DataPointAny) -> DataPoint a -> DataPointAny
forall a b. (a -> b) -> a -> b
$ Text -> UTCTime -> a -> DataPoint a
forall a. Text -> UTCTime -> a -> DataPoint a
DataPoint Text
name UTCTime
now a
value
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan DataPointAny -> DataPointAny -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan DataPointAny
chan DataPointAny
dat
withNept :: Text
-> (NeptuneSession -> Experiment -> IO a)
-> IO a
withNept :: Text -> (NeptuneSession -> Experiment -> IO a) -> IO a
withNept Text
project_qualified_name NeptuneSession -> Experiment -> IO a
act = do
Text
args <- [Text] -> Text
T.unwords ([Text] -> Text) -> ([String] -> [Text]) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> Text) -> IO [String] -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
[(String, String)]
envs <- IO [(String, String)]
getEnvironment
let valid_pat :: Text -> Bool
valid_pat Text
name = Text -> Text -> Bool
T.isPrefixOf Text
"MXNET_" Text
name Bool -> Bool -> Bool
||
Text -> Text -> Bool
T.isPrefixOf Text
"NVIDIA_" Text
name Bool -> Bool -> Bool
||
Text -> Text -> Bool
T.isPrefixOf Text
"CUDA_" Text
name
[(Text, Text)]
envs <- [(Text, Text)] -> IO [(Text, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Text)] -> IO [(Text, Text)])
-> [(Text, Text)] -> IO [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
envs [(String, String)]
-> Getting (Endo [(Text, Text)]) [(String, String)] (Text, Text)
-> [(Text, Text)]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((String, String) -> Const (Endo [(Text, Text)]) (String, String))
-> [(String, String)]
-> Const (Endo [(Text, Text)]) [(String, String)]
forall s t a b. Each s t a b => Traversal s t a b
each (((String, String) -> Const (Endo [(Text, Text)]) (String, String))
-> [(String, String)]
-> Const (Endo [(Text, Text)]) [(String, String)])
-> (((Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> (String, String)
-> Const (Endo [(Text, Text)]) (String, String))
-> Getting (Endo [(Text, Text)]) [(String, String)] (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnIso String String Text Text
-> AnIso String String Text Text
-> Iso (String, String) (String, String) (Text, Text) (Text, Text)
forall (f :: * -> * -> *) (g :: * -> * -> *) s t a b s' t' a' b'.
(Bifunctor f, Bifunctor g) =>
AnIso s t a b
-> AnIso s' t' a' b' -> Iso (f s s') (g t t') (f a a') (g b b')
bimapping AnIso String String Text Text
forall t. IsText t => Iso' String t
packed AnIso String String Text Text
forall t. IsText t => Iso' String t
packed (((Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> (String, String)
-> Const (Endo [(Text, Text)]) (String, String))
-> (((Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> (Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> ((Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> (String, String)
-> Const (Endo [(Text, Text)]) (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Bool)
-> ((Text, Text) -> Const (Endo [(Text, Text)]) (Text, Text))
-> (Text, Text)
-> Const (Endo [(Text, Text)]) (Text, Text)
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (Text -> Bool
valid_pat (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst)
Text
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> (NeptuneSession -> Experiment -> IO a)
-> IO a
forall a.
Text
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> (NeptuneSession -> Experiment -> IO a)
-> IO a
withNept' Text
project_qualified_name Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing [] ((Text
"args", Text
args) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
envs) [] NeptuneSession -> Experiment -> IO a
act
withNept' :: Text
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> (NeptuneSession -> Experiment -> IO a)
-> IO a
withNept' :: Text
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> (NeptuneSession -> Experiment -> IO a)
-> IO a
withNept' Text
project_qualified_name Maybe Text
name Maybe Text
description [Parameter]
params [(Text, Text)]
props [Text]
tags NeptuneSession -> Experiment -> IO a
act = do
NeptuneSession
ses <- HasCallStack => Text -> IO NeptuneSession
Text -> IO NeptuneSession
initNept Text
project_qualified_name
Experiment
exp <- HasCallStack =>
NeptuneSession
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> IO Experiment
NeptuneSession
-> Maybe Text
-> Maybe Text
-> [Parameter]
-> [(Text, Text)]
-> [Text]
-> IO Experiment
createExperiment NeptuneSession
ses Maybe Text
name Maybe Text
description [Parameter]
params [(Text, Text)]
props [Text]
tags
ThreadId
main_thread <- IO ThreadId
forall (m :: * -> *). MonadIO m => m ThreadId
myThreadId
let interrupted :: IO ()
interrupted = ThreadId -> AsyncException -> IO ()
forall e (m :: * -> *).
(Exception e, MonadIO m) =>
ThreadId -> e -> m ()
throwTo ThreadId
main_thread AsyncException
UserInterrupt
Handler
old_handler <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
keyboardSignal (IO () -> Handler
Catch IO ()
interrupted) Maybe SignalSet
forall a. Maybe a
Nothing
Either SomeException a
result <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (NeptuneSession -> Experiment -> IO a
act NeptuneSession
ses Experiment
exp)
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
keyboardSignal Handler
old_handler Maybe SignalSet
forall a. Maybe a
Nothing
case Either SomeException a
result of
Left (SomeException
e :: SomeException) -> do
let end_state :: Maybe (ExperimentState, Text)
end_state = case SomeException -> Maybe AbortException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just AbortException
AbortException -> Maybe (ExperimentState, Text)
forall a. Maybe a
Nothing
Maybe AbortException
_ -> (ExperimentState, Text) -> Maybe (ExperimentState, Text)
forall a. a -> Maybe a
Just ((ExperimentState, Text) -> Maybe (ExperimentState, Text))
-> (ExperimentState, Text) -> Maybe (ExperimentState, Text)
forall a b. (a -> b) -> a -> b
$
case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException SomeException
e of
Just AsyncException
UserInterrupt -> (ExperimentState
ExperimentState'Failed, Text
"User interrupted.")
Maybe AsyncException
_ -> (ExperimentState
ExperimentState'Failed, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
NeptuneSession
-> Experiment -> Maybe (ExperimentState, Text) -> IO ()
teardownNept NeptuneSession
ses Experiment
exp Maybe (ExperimentState, Text)
end_state
SomeException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
Right a
a -> do
NeptuneSession
-> Experiment -> Maybe (ExperimentState, Text) -> IO ()
teardownNept NeptuneSession
ses Experiment
exp ((ExperimentState, Text) -> Maybe (ExperimentState, Text)
forall a. a -> Maybe a
Just (ExperimentState
ExperimentState'Succeeded, Text
""))
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
initNept :: HasCallStack
=> Text
-> IO NeptuneSession
initNept :: Text -> IO NeptuneSession
initNept Text
project_qualified_name = do
ct :: ClientToken
ct@ClientToken{Text
_ct_api_key :: ClientToken -> Text
_ct_api_url :: ClientToken -> Text
_ct_api_address :: ClientToken -> Text
_ct_token :: ClientToken -> Text
_ct_api_key :: Text
_ct_api_url :: Text
_ct_api_address :: Text
_ct_token :: Text
..} <- IO (Either String ClientToken)
forall a. FromEnv a => IO (Either String a)
decodeEnv IO (Either String ClientToken)
-> (Either String ClientToken -> IO ClientToken) -> IO ClientToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ClientToken)
-> (ClientToken -> IO ClientToken)
-> Either String ClientToken
-> IO ClientToken
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ClientToken
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString ClientToken -> IO ClientToken
forall (m :: * -> *) a. Monad m => a -> m a
return
Manager
mgr <- ManagerSettings -> IO Manager
NH.newManager ManagerSettings
NH.tlsManagerSettings
NeptuneBackendConfig
config0 <- NeptuneBackendConfig -> IO NeptuneBackendConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NeptuneBackendConfig -> IO NeptuneBackendConfig)
-> (NeptuneBackendConfig -> NeptuneBackendConfig)
-> NeptuneBackendConfig
-> IO NeptuneBackendConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeptuneBackendConfig -> NeptuneBackendConfig
withNoLogging (NeptuneBackendConfig -> IO NeptuneBackendConfig)
-> IO NeptuneBackendConfig -> IO NeptuneBackendConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NeptuneBackendConfig
newConfig
let api_endpoint :: ByteString
api_endpoint = Text -> ByteString
TL.encodeUtf8 (Text -> Text
TL.fromStrict Text
_ct_api_url)
config :: NeptuneBackendConfig
config = NeptuneBackendConfig
config0 { configHost :: ByteString
configHost = ByteString
api_endpoint }
let dispatch :: NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO NeptuneOauthToken
dispatch = Manager
-> NeptuneBackendConfig
-> NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO (MimeResult NeptuneOauthToken)
forall req contentType res accept.
(Produces req accept, MimeUnrender accept res,
MimeType contentType) =>
Manager
-> NeptuneBackendConfig
-> NeptuneBackendRequest req contentType res accept
-> IO (MimeResult res)
dispatchMime Manager
mgr NeptuneBackendConfig
config{configValidateAuthMethods :: Bool
configValidateAuthMethods = Bool
False}
(NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO (MimeResult NeptuneOauthToken))
-> (MimeResult NeptuneOauthToken -> IO NeptuneOauthToken)
-> NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO NeptuneOauthToken
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MimeResult NeptuneOauthToken -> IO NeptuneOauthToken
forall (m :: * -> *) a.
(Monad m, HasCallStack) =>
MimeResult a -> m a
handleMimeError
NeptuneOauthToken
oauth_token <- NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO NeptuneOauthToken
dispatch (NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO NeptuneOauthToken)
-> NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
-> IO NeptuneOauthToken
forall a b. (a -> b) -> a -> b
$ Accept MimeJSON
-> XNeptuneApiToken
-> NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken MimeJSON
forall accept.
Accept accept
-> XNeptuneApiToken
-> NeptuneBackendRequest
ExchangeApiToken MimeNoContent NeptuneOauthToken accept
NBAPI.exchangeApiToken (MimeJSON -> Accept MimeJSON
forall a. MimeType a => a -> Accept a
Accept MimeJSON
MimeJSON) (Text -> XNeptuneApiToken
XNeptuneApiToken Text
_ct_token)
(ThreadId
refresh_thread, MVar OAuth2Session
oauth_session) <- Text -> Text -> IO (ThreadId, MVar OAuth2Session)
oauth2Setup (NeptuneOauthToken
oauth_token NeptuneOauthToken -> Getting Text NeptuneOauthToken Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text NeptuneOauthToken Text
Lens_' NeptuneOauthToken Text
neptuneOauthTokenAccessTokenL)
(NeptuneOauthToken
oauth_token NeptuneOauthToken -> Getting Text NeptuneOauthToken Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text NeptuneOauthToken Text
Lens_' NeptuneOauthToken Text
neptuneOauthTokenRefreshTokenL)
let dispatch :: (HasCallStack, Produces req accept, MimeUnrender accept res, MimeType contentType)
=> NeptuneBackendRequest req contentType res accept -> IO res
dispatch :: NeptuneBackendRequest req contentType res accept -> IO res
dispatch NeptuneBackendRequest req contentType res accept
req = do
Text
access_token <- MVar OAuth2Session -> IO OAuth2Session
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar OAuth2Session
oauth_session IO OAuth2Session -> (OAuth2Session -> Text) -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> OAuth2Session -> Text
_oas_access_token
MimeResult res
resp <- Manager
-> NeptuneBackendConfig
-> NeptuneBackendRequest req contentType res accept
-> IO (MimeResult res)
forall req contentType res accept.
(Produces req accept, MimeUnrender accept res,
MimeType contentType) =>
Manager
-> NeptuneBackendConfig
-> NeptuneBackendRequest req contentType res accept
-> IO (MimeResult res)
dispatchMime Manager
mgr (NeptuneBackendConfig
config NeptuneBackendConfig -> AuthOAuthOauth2 -> NeptuneBackendConfig
forall auth.
AuthMethod auth =>
NeptuneBackendConfig -> auth -> NeptuneBackendConfig
`addAuthMethod` Text -> AuthOAuthOauth2
AuthOAuthOauth2 Text
access_token) NeptuneBackendRequest req contentType res accept
req
MimeResult res -> IO res
forall (m :: * -> *) a.
(Monad m, HasCallStack) =>
MimeResult a -> m a
handleMimeError MimeResult res
resp
ProjectWithRoleDTO
proj <- NeptuneBackendRequest
GetProject MimeNoContent ProjectWithRoleDTO MimeJSON
-> IO ProjectWithRoleDTO
forall req accept res contentType.
(HasCallStack, Produces req accept, MimeUnrender accept res,
MimeType contentType) =>
NeptuneBackendRequest req contentType res accept -> IO res
dispatch (NeptuneBackendRequest
GetProject MimeNoContent ProjectWithRoleDTO MimeJSON
-> IO ProjectWithRoleDTO)
-> NeptuneBackendRequest
GetProject MimeNoContent ProjectWithRoleDTO MimeJSON
-> IO ProjectWithRoleDTO
forall a b. (a -> b) -> a -> b
$ Accept MimeJSON
-> ProjectIdentifier
-> NeptuneBackendRequest
GetProject MimeNoContent ProjectWithRoleDTO MimeJSON
forall accept.
Accept accept
-> ProjectIdentifier
-> NeptuneBackendRequest
GetProject MimeNoContent ProjectWithRoleDTO accept
NBAPI.getProject (MimeJSON -> Accept MimeJSON
forall a. MimeType a => a -> Accept a
Accept MimeJSON
MimeJSON) (Text -> ProjectIdentifier
ProjectIdentifier Text
project_qualified_name)
NeptuneSession -> IO NeptuneSession
forall (m :: * -> *) a. Monad m => a -> m a
return (NeptuneSession -> IO NeptuneSession)
-> NeptuneSession -> IO NeptuneSession
forall a b. (a -> b) -> a -> b
$ NeptuneSession :: Manager
-> ClientToken
-> NeptuneBackendConfig
-> MVar OAuth2Session
-> ThreadId
-> ProjectWithRoleDTO
-> Dispatcher
-> NeptuneSession
NeptuneSession
{ _neptune_http_manager :: Manager
_neptune_http_manager = Manager
mgr
, _neptune_client_token :: ClientToken
_neptune_client_token = ClientToken
ct
, _neptune_config :: NeptuneBackendConfig
_neptune_config = NeptuneBackendConfig
config
, _neptune_oauth2 :: MVar OAuth2Session
_neptune_oauth2 = MVar OAuth2Session
oauth_session
, _neptune_oauth2_refresh :: ThreadId
_neptune_oauth2_refresh = ThreadId
refresh_thread
, _neptune_project :: ProjectWithRoleDTO
_neptune_project = ProjectWithRoleDTO
proj
, _neptune_dispatch :: Dispatcher
_neptune_dispatch = forall req accept res contentType.
(HasCallStack, Produces req accept, MimeUnrender accept res,
MimeType contentType) =>
NeptuneBackendRequest req contentType res accept -> IO res
Dispatcher
dispatch
}
teardownNept :: NeptuneSession
-> Experiment
-> Maybe (ExperimentState, Text)
-> IO ()
teardownNept :: NeptuneSession
-> Experiment -> Maybe (ExperimentState, Text) -> IO ()
teardownNept NeptuneSession{ThreadId
MVar OAuth2Session
Manager
NeptuneBackendConfig
ProjectWithRoleDTO
ClientToken
Dispatcher
_neptune_dispatch :: Dispatcher
_neptune_project :: ProjectWithRoleDTO
_neptune_oauth2_refresh :: ThreadId
_neptune_oauth2 :: MVar OAuth2Session
_neptune_config :: NeptuneBackendConfig
_neptune_client_token :: ClientToken
_neptune_http_manager :: Manager
_neptune_dispatch :: NeptuneSession -> Dispatcher
_neptune_project :: NeptuneSession -> ProjectWithRoleDTO
_neptune_oauth2_refresh :: NeptuneSession -> ThreadId
_neptune_oauth2 :: NeptuneSession -> MVar OAuth2Session
_neptune_config :: NeptuneSession -> NeptuneBackendConfig
_neptune_client_token :: NeptuneSession -> ClientToken
_neptune_http_manager :: NeptuneSession -> Manager
..} Experiment
experiment Maybe (ExperimentState, Text)
state_msg = do
Event -> IO ()
E.set (Experiment
experiment Experiment -> Getting Event Experiment Event -> Event
forall s a. s -> Getting a s a -> a
^. Getting Event Experiment Event
Lens' Experiment Event
exp_stop_flag)
Bool
done <- Event -> Integer -> IO Bool
E.waitTimeout (Experiment
experiment Experiment -> Getting Event Experiment Event -> Event
forall s a. s -> Getting a s a -> a
^. Getting Event Experiment Event
Lens' Experiment Event
exp_transmitter_flag) Integer
5000000
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ThreadId -> IO ()
killThread (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ Experiment
experiment Experiment -> Getting ThreadId Experiment ThreadId -> ThreadId
forall s a. s -> Getting a s a -> a
^. Getting ThreadId Experiment ThreadId
Lens' Experiment ThreadId
exp_transmitter
ThreadId -> IO ()
killThread (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId
_neptune_oauth2_refresh
case Maybe (ExperimentState, Text)
state_msg of
Just (ExperimentState
state, Text
msg) ->
IO NoContent -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (NeptuneBackendRequest
MarkExperimentCompleted MimeJSON NoContent MimeNoContent
-> IO NoContent
Dispatcher
_neptune_dispatch (NeptuneBackendRequest
MarkExperimentCompleted MimeJSON NoContent MimeNoContent
-> IO NoContent)
-> NeptuneBackendRequest
MarkExperimentCompleted MimeJSON NoContent MimeNoContent
-> IO NoContent
forall a b. (a -> b) -> a -> b
$ ContentType MimeJSON
-> Accept MimeNoContent
-> CompletedExperimentParams
-> ExperimentId
-> NeptuneBackendRequest
MarkExperimentCompleted MimeJSON NoContent MimeNoContent
forall contentType accept res.
(Consumes MarkExperimentCompleted contentType,
MimeRender contentType CompletedExperimentParams) =>
ContentType contentType
-> Accept accept
-> CompletedExperimentParams
-> ExperimentId
-> NeptuneBackendRequest
MarkExperimentCompleted contentType res accept
NBAPI.markExperimentCompleted
(MimeJSON -> ContentType MimeJSON
forall a. MimeType a => a -> ContentType a
ContentType MimeJSON
MimeJSON)
(MimeNoContent -> Accept MimeNoContent
forall a. MimeType a => a -> Accept a
Accept MimeNoContent
MimeNoContent)
(ExperimentState -> Text -> CompletedExperimentParams
mkCompletedExperimentParams ExperimentState
state Text
msg)
(Experiment
experiment Experiment
-> Getting ExperimentId Experiment ExperimentId -> ExperimentId
forall s a. s -> Getting a s a -> a
^. Getting ExperimentId Experiment ExperimentId
Lens' Experiment ExperimentId
exp_experiment_id) :: IO NoContent)
Maybe (ExperimentState, Text)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()