{-|
Module      : Neptune.Client
Description : Neptune Client
Copyright   : (c) Jiasen Wu, 2020
License     : BSD-3-Clause
-}
{-# 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


-- | Experiment's hyper-parameter. When creating an experiment, you could
-- specify parameters to present in the web console.
data Parameter = ExperimentParamS Text Text
    | ExperimentParamD Text Double

-- | Create an experiment
createExperiment :: HasCallStack
                 => NeptuneSession -- ^ Session
                 -> Maybe Text -- ^ Optional name (automatically assigned if Nothing)
                 -> Maybe Text -- ^ Optional description
                 -> [Parameter] -- ^ hyper-parameters
                 -> [(Text, Text)] -- ^ properties
                 -> [Text] -- ^ tags
                 -> 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
    -- TODO support git_info
    -- TODO support uploading source code
    -- TODO support abort callback. W/o a callback, the app will
    --      continue running when you click abort in the web console
    [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
"" -- legacy
                    [Parameter]
params
                    Text
"command" -- legacy
                    (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)

-- | Log a key-value pair
nlog :: (HasCallStack, NeptDataType a)
     => Experiment -- ^ experiment
     -> Text -- ^ key
     -> a -- ^ value
     -> 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

-- | Run an action within a neptune session and a new experiment
withNept :: Text -- ^ \<namespace\>\/\<project_name\>
         -> (NeptuneSession -> Experiment -> IO a) -- ^ action
         -> 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

-- | Run an action within a neptune session and a new experiment
withNept' :: Text -- ^ \<namespace\>\/\<project_name\>
          -> Maybe Text -- ^ Optional name of the experiment (automatically assigned if Nothing)
          -> Maybe Text -- ^ Optional description of the experiment
          -> [Parameter] -- ^ experiment hyper-parameters
          -> [(Text, Text)] -- ^ experiment properties
          -> [Text] -- ^ experiment tags
          -> (NeptuneSession -> Experiment -> IO a) -- ^ action
          -> 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

    -- install an signal handler for CTRL-C, ensuring that an async-
    -- exception UserInterrupt is sent to the main thread
    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

-- | Initialize a neptune session
initNept :: HasCallStack
         => Text -- ^ \<namespace\>\/\<project_name\>
         -> 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)

    -- TODO there is a chance that the access token gets invalid right after readMVar
    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
        }

-- | Teardown a neptune session
teardownNept :: NeptuneSession -- ^ session
             -> Experiment -- ^ experiment
             -> Maybe (ExperimentState, Text) -- ^ completion state & message
             -> 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)
    -- wait at most 5 seconds
    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
    -- kill if timeout
    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 ()