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


-- | Decoded client token
data ClientToken = ClientToken
    { ClientToken -> Text
_ct_token       :: Text -- ^ user secret
    , ClientToken -> Text
_ct_api_address :: Text -- ^ neptune api address
    , ClientToken -> Text
_ct_api_url     :: Text -- ^ neptune api address
    , ClientToken -> Text
_ct_api_key     :: Text -- ^ neptune api key (not used)
    }
    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

-- | Neptune session. It contains all necessary information to communicate the
-- server.
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 -- ^ Background thread for updating OAuth2 token
    , NeptuneSession -> ProjectWithRoleDTO
_neptune_project        :: ProjectWithRoleDTO -- ^ Active project
    , 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 -- ^ Dispatching function for http requests
    }

data Experiment = Experiment
    { Experiment -> ExperimentId
_exp_experiment_id    :: ExperimentId -- ^ Experiment Id
    , Experiment -> TChan DataPointAny
_exp_outbound_q       :: TChan DataPointAny -- ^ Output queue
    , Experiment -> ChannelHashMap
_exp_user_channels    :: ChannelHashMap -- ^ Active output channels
    , Experiment -> Event
_exp_stop_flag        :: E.Event -- ^ Event flag to indicate the end of the session
    , Experiment -> Event
_exp_transmitter_flag :: E.Event -- ^ Event flag to indicate completion of transmission
    , Experiment -> ThreadId
_exp_transmitter      :: ThreadId -- ^ Background thread for transmission
    , Experiment -> ThreadId
_exp_abort_handler    :: ThreadId
    }

class (Typeable a, Show a) => NeptDataType a where
    neptChannelType :: Proxy a -> ChannelTypeEnum
    toNeptPoint     :: DataPoint a -> Point

-- | Type-safe data channel
newtype DataChannel a = DataChannel Text {- ^ Channel Id -}
    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 channel of any type
data DataChannelAny = forall a . NeptDataType a => DataChannelAny (DataChannel a)
deriving instance Show DataChannelAny

-- | Hashmap of all channels in use
type ChannelHashMap = TVar (HashMap Text DataChannelAny)

-- | Type-safe data point
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 point of any type
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

-- | Lens to get/set '_dpt_name' for 'DataPointAny'
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

-- | Lens to get/set '_dpt_timestamp' for 'DataPointAny'
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