{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Neptune.Session where
import Control.Concurrent (ThreadId)
import Control.Concurrent.Event as E (Event)
import Control.Lens
import Control.Monad.Except (MonadError (throwError))
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import qualified Data.ByteString.Base64 as Base64
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import qualified Network.HTTP.Client as NH
import RIO hiding (Lens', (^.))
import qualified RIO.Text as T
import System.Envy (FromEnv (..), Parser, env)
import Neptune.Backend.Core
import Neptune.Backend.MimeTypes
import Neptune.Backend.Model hiding (Experiment, Parameter)
import Neptune.OAuth
data ClientToken = ClientToken
{ ClientToken -> Text
_ct_token :: Text
, ClientToken -> Text
_ct_api_address :: Text
, ClientToken -> Text
_ct_api_url :: Text
, ClientToken -> Text
_ct_api_key :: Text
}
deriving ((forall x. ClientToken -> Rep ClientToken x)
-> (forall x. Rep ClientToken x -> ClientToken)
-> Generic ClientToken
forall x. Rep ClientToken x -> ClientToken
forall x. ClientToken -> Rep ClientToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ClientToken x -> ClientToken
$cfrom :: forall x. ClientToken -> Rep ClientToken x
Generic, Int -> ClientToken -> ShowS
[ClientToken] -> ShowS
ClientToken -> String
(Int -> ClientToken -> ShowS)
-> (ClientToken -> String)
-> ([ClientToken] -> ShowS)
-> Show ClientToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientToken] -> ShowS
$cshowList :: [ClientToken] -> ShowS
show :: ClientToken -> String
$cshow :: ClientToken -> String
showsPrec :: Int -> ClientToken -> ShowS
$cshowsPrec :: Int -> ClientToken -> ShowS
Show)
instance FromEnv ClientToken where
fromEnv :: Maybe ClientToken -> Parser ClientToken
fromEnv Maybe ClientToken
_ = do
Text
token <- String -> Parser Text
forall a. Var a => String -> Parser a
env String
"NEPTUNE_API_TOKEN"
ByteString
jsraw <- (String -> Parser ByteString)
-> (ByteString -> Parser ByteString)
-> Either String ByteString
-> Parser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> Parser ByteString)
-> Either String ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
token
Value
js <- (String -> Parser Value)
-> (Value -> Parser Value) -> Either String Value -> Parser Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Value -> Parser Value)
-> Either String Value -> Parser Value
forall a b. (a -> b) -> a -> b
$
ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
jsraw :: Parser Aeson.Value
ClientToken -> Parser ClientToken
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientToken -> Parser ClientToken)
-> ClientToken -> Parser ClientToken
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> ClientToken
ClientToken
Text
token
(Value
js Value -> Getting (Endo Text) Value Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"api_address" ((Value -> Const (Endo Text) Value)
-> Value -> Const (Endo Text) Value)
-> Getting (Endo Text) Value Text -> Getting (Endo Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String)
(Value
js Value -> Getting (Endo Text) Value Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"api_url" ((Value -> Const (Endo Text) Value)
-> Value -> Const (Endo Text) Value)
-> Getting (Endo Text) Value Text -> Getting (Endo Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String)
(Value
js Value -> Getting (Endo Text) Value Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"api_key" ((Value -> Const (Endo Text) Value)
-> Value -> Const (Endo Text) Value)
-> Getting (Endo Text) Value Text -> Getting (Endo Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String)
type Dispatcher = forall req contentType res accept .
(Produces req accept, MimeUnrender accept res, MimeType contentType, HasCallStack)
=> NeptuneBackendRequest req contentType res accept
-> IO res
data NeptuneSession = NeptuneSession
{ NeptuneSession -> Manager
_neptune_http_manager :: NH.Manager
, NeptuneSession -> ClientToken
_neptune_client_token :: ClientToken
, NeptuneSession -> NeptuneBackendConfig
_neptune_config :: NeptuneBackendConfig
, NeptuneSession -> MVar OAuth2Session
_neptune_oauth2 :: MVar OAuth2Session
, NeptuneSession -> ThreadId
_neptune_oauth2_refresh :: ThreadId
, NeptuneSession -> ProjectWithRoleDTO
_neptune_project :: ProjectWithRoleDTO
, NeptuneSession
-> forall req contentType res accept.
(Produces req accept, MimeUnrender accept res,
MimeType contentType, HasCallStack) =>
NeptuneBackendRequest req contentType res accept -> IO res
_neptune_dispatch :: Dispatcher
}
data Experiment = Experiment
{ Experiment -> ExperimentId
_exp_experiment_id :: ExperimentId
, Experiment -> TChan DataPointAny
_exp_outbound_q :: TChan DataPointAny
, Experiment -> ChannelHashMap
_exp_user_channels :: ChannelHashMap
, Experiment -> Event
_exp_stop_flag :: E.Event
, Experiment -> Event
_exp_transmitter_flag :: E.Event
, Experiment -> ThreadId
_exp_transmitter :: ThreadId
, Experiment -> ThreadId
_exp_abort_handler :: ThreadId
}
class (Typeable a, Show a) => NeptDataType a where
neptChannelType :: Proxy a -> ChannelTypeEnum
toNeptPoint :: DataPoint a -> Point
newtype DataChannel a = DataChannel Text
deriving Int -> DataChannel a -> ShowS
[DataChannel a] -> ShowS
DataChannel a -> String
(Int -> DataChannel a -> ShowS)
-> (DataChannel a -> String)
-> ([DataChannel a] -> ShowS)
-> Show (DataChannel a)
forall a. Int -> DataChannel a -> ShowS
forall a. [DataChannel a] -> ShowS
forall a. DataChannel a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataChannel a] -> ShowS
$cshowList :: forall a. [DataChannel a] -> ShowS
show :: DataChannel a -> String
$cshow :: forall a. DataChannel a -> String
showsPrec :: Int -> DataChannel a -> ShowS
$cshowsPrec :: forall a. Int -> DataChannel a -> ShowS
Show
data DataChannelAny = forall a . NeptDataType a => DataChannelAny (DataChannel a)
deriving instance Show DataChannelAny
type ChannelHashMap = TVar (HashMap Text DataChannelAny)
data DataPoint a = DataPoint
{ DataPoint a -> Text
_dpt_name :: Text
, DataPoint a -> UTCTime
_dpt_timestamp :: UTCTime
, DataPoint a -> a
_dpt_value :: a
}
deriving Int -> DataPoint a -> ShowS
[DataPoint a] -> ShowS
DataPoint a -> String
(Int -> DataPoint a -> ShowS)
-> (DataPoint a -> String)
-> ([DataPoint a] -> ShowS)
-> Show (DataPoint a)
forall a. Show a => Int -> DataPoint a -> ShowS
forall a. Show a => [DataPoint a] -> ShowS
forall a. Show a => DataPoint a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataPoint a] -> ShowS
$cshowList :: forall a. Show a => [DataPoint a] -> ShowS
show :: DataPoint a -> String
$cshow :: forall a. Show a => DataPoint a -> String
showsPrec :: Int -> DataPoint a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> DataPoint a -> ShowS
Show
data DataPointAny = forall a . NeptDataType a => DataPointAny (DataPoint a)
deriving instance Show DataPointAny
makeLenses ''ClientToken
makeLensesFor [("_neptune_http_manager", "neptune_http_manager")
,("_neptune_client_token", "neptune_client_token")
,("_neptune_config", "neptune_config")
,("_neptune_oauth2", "neptune_oauth2")
,("_neptune_oauth2_refresh", "neptune_oauth2_refresh")
,("_neptune_project", "neptune_project")]
''NeptuneSession
makeLenses ''Experiment
makeLenses ''DataPoint
dpt_name_A :: Lens' DataPointAny Text
dpt_name_A :: (Text -> f Text) -> DataPointAny -> f DataPointAny
dpt_name_A Text -> f Text
f (DataPointAny (DataPoint Text
n UTCTime
t a
v)) =
let set :: Text -> DataPointAny
set = (\Text
n -> DataPoint a -> DataPointAny
forall a. NeptDataType a => DataPoint a -> DataPointAny
DataPointAny (Text -> UTCTime -> a -> DataPoint a
forall a. Text -> UTCTime -> a -> DataPoint a
DataPoint Text
n UTCTime
t a
v))
in Text -> DataPointAny
set (Text -> DataPointAny) -> f Text -> f DataPointAny
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f Text
n
dpt_timestamp_A :: Lens' DataPointAny UTCTime
dpt_timestamp_A :: (UTCTime -> f UTCTime) -> DataPointAny -> f DataPointAny
dpt_timestamp_A UTCTime -> f UTCTime
f (DataPointAny (DataPoint Text
n UTCTime
t a
v)) =
let set :: UTCTime -> DataPointAny
set = (\UTCTime
t -> DataPoint a -> DataPointAny
forall a. NeptDataType a => DataPoint a -> DataPointAny
DataPointAny (Text -> UTCTime -> a -> DataPoint a
forall a. Text -> UTCTime -> a -> DataPoint a
DataPoint Text
n UTCTime
t a
v))
in UTCTime -> DataPointAny
set (UTCTime -> DataPointAny) -> f UTCTime -> f DataPointAny
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> f UTCTime
f UTCTime
t
instance NeptDataType Double where
neptChannelType :: Proxy Double -> ChannelTypeEnum
neptChannelType Proxy Double
_ = ChannelTypeEnum
ChannelTypeEnum'Numeric
toNeptPoint :: DataPoint Double -> Point
toNeptPoint DataPoint Double
dat = let t :: Integer
t = POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (DataPoint Double
dat DataPoint Double
-> Getting UTCTime (DataPoint Double) UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. Getting UTCTime (DataPoint Double) UTCTime
forall a. Lens' (DataPoint a) UTCTime
dpt_timestamp) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000
y :: Y
y = Y
mkY{ yNumericValue :: Maybe Double
yNumericValue = DataPoint Double
dat DataPoint Double
-> Getting (Maybe Double) (DataPoint Double) (Maybe Double)
-> Maybe Double
forall s a. s -> Getting a s a -> a
^. (Double -> Const (Maybe Double) Double)
-> DataPoint Double -> Const (Maybe Double) (DataPoint Double)
forall a a. Lens (DataPoint a) (DataPoint a) a a
dpt_value ((Double -> Const (Maybe Double) Double)
-> DataPoint Double -> Const (Maybe Double) (DataPoint Double))
-> ((Maybe Double -> Const (Maybe Double) (Maybe Double))
-> Double -> Const (Maybe Double) Double)
-> Getting (Maybe Double) (DataPoint Double) (Maybe Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview (Maybe Double) Double -> Getter Double (Maybe Double)
forall t b. AReview t b -> Getter b t
re AReview (Maybe Double) Double
forall a b. Prism (Maybe a) (Maybe b) a b
_Just }
in Integer -> Y -> Point
mkPoint Integer
t Y
y