{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}

module Asapo.Either.Common
  ( SourceType (..),
    InstanceId (..),
    PipelineStep (..),
    Beamline (..),
    withPtr,
    Beamtime (..),
    messageIdFromInt,
    MessageId (..),
    stringHandleToText,
    DataSource (..),
    Token (..),
    timespecToUTC,
    SourceCredentials (..),
    withCredentials,
    withText,
    StreamName (..),
    withCStringN,
    withCStringNToText,
    withConstText,
    withConstCString,
    peekConstCStringText,
    peekCStringText,
    stringHandleToTextUnsafe,
    nominalDiffToMillis,
    retrieveStreamInfoFromC,
    StreamInfo (..),
  )
where

-- \|
-- Description : Utility module with common definitions
--
-- You shouldn't need to explicitly import anything from here
import Asapo.Raw.Common (AsapoSourceCredentialsHandle, AsapoStreamInfoHandle, AsapoStringHandle (AsapoStringHandle), ConstCString, asapo_create_source_credentials, asapo_free_source_credentials, asapo_stream_info_get_finished, asapo_stream_info_get_last_id, asapo_stream_info_get_name, asapo_stream_info_get_next_stream, asapo_stream_info_get_timestamp_created, asapo_stream_info_get_timestamp_last_entry, asapo_string_c_str, kProcessed, kRaw)
import Control.Applicative (pure)
import Control.Exception (bracket)
import Control.Monad (Monad ((>>=)), (>=>))
import Data.Bool (Bool, otherwise)
import Data.Eq ((==))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe (Just, Nothing), fromJust)
import Data.Ord ((>))
import Data.String (String)
import Data.Text (Text, pack, unpack)
import Data.Time (NominalDiffTime, zonedTimeToUTC)
import Data.Time.Clock (UTCTime, addUTCTime)
import qualified Data.Time.RFC3339 as RFC3339
import Data.Word (Word64)
import Foreign (Ptr, Storable (peek), nullPtr, with)
import Foreign.C (CChar)
import Foreign.C.ConstPtr (ConstPtr (ConstPtr, unConstPtr))
import Foreign.C.String (CString, peekCString, withCString)
import Foreign.Marshal (alloca, mallocArray)
import Foreign.Marshal.Alloc (free)
import System.Clock (TimeSpec, toNanoSecs)
import System.IO (IO)
import Text.Show (Show)
import Prelude (Fractional ((/)), Integral, Num (fromInteger, (*)), RealFrac (round), fromIntegral)

withText :: Text -> (CString -> IO a) -> IO a
withText :: forall a. Text -> (CString -> IO a) -> IO a
withText Text
t = String -> (CString -> IO a) -> IO a
forall a. String -> (CString -> IO a) -> IO a
withCString (Text -> String
unpack Text
t)

nominalDiffToMillis :: (Integral a) => NominalDiffTime -> a
nominalDiffToMillis :: forall a. Integral a => NominalDiffTime -> a
nominalDiffToMillis = NominalDiffTime -> a
forall a. Integral a => NominalDiffTime -> a
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> a)
-> (NominalDiffTime -> NominalDiffTime) -> NominalDiffTime -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000)

newtype MessageId = MessageId Word64 deriving (Int -> MessageId -> ShowS
[MessageId] -> ShowS
MessageId -> String
(Int -> MessageId -> ShowS)
-> (MessageId -> String)
-> ([MessageId] -> ShowS)
-> Show MessageId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageId -> ShowS
showsPrec :: Int -> MessageId -> ShowS
$cshow :: MessageId -> String
show :: MessageId -> String
$cshowList :: [MessageId] -> ShowS
showList :: [MessageId] -> ShowS
Show)

messageIdFromInt :: (Integral a) => a -> MessageId
messageIdFromInt :: forall a. Integral a => a -> MessageId
messageIdFromInt = Word64 -> MessageId
MessageId (Word64 -> MessageId) -> (a -> Word64) -> a -> MessageId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

newtype StreamName = StreamName Text deriving (Int -> StreamName -> ShowS
[StreamName] -> ShowS
StreamName -> String
(Int -> StreamName -> ShowS)
-> (StreamName -> String)
-> ([StreamName] -> ShowS)
-> Show StreamName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StreamName -> ShowS
showsPrec :: Int -> StreamName -> ShowS
$cshow :: StreamName -> String
show :: StreamName -> String
$cshowList :: [StreamName] -> ShowS
showList :: [StreamName] -> ShowS
Show)

data SourceType = RawSource | ProcessedSource

newtype InstanceId = InstanceId Text

newtype PipelineStep = PipelineStep Text

newtype Beamtime = Beamtime Text

newtype Beamline = Beamline Text

newtype DataSource = DataSource Text

newtype Token = Token Text

data SourceCredentials = SourceCredentials
  { SourceCredentials -> SourceType
sourceType :: SourceType,
    SourceCredentials -> InstanceId
instanceId :: InstanceId,
    SourceCredentials -> PipelineStep
pipelineStep :: PipelineStep,
    SourceCredentials -> Beamtime
beamtime :: Beamtime,
    SourceCredentials -> Beamline
beamline :: Beamline,
    SourceCredentials -> DataSource
dataSource :: DataSource,
    SourceCredentials -> Token
token :: Token
  }

withCredentials :: SourceCredentials -> (AsapoSourceCredentialsHandle -> IO a) -> IO a
withCredentials :: forall a.
SourceCredentials -> (AsapoSourceCredentialsHandle -> IO a) -> IO a
withCredentials
  ( SourceCredentials
      { SourceType
sourceType :: SourceCredentials -> SourceType
sourceType :: SourceType
sourceType,
        instanceId :: SourceCredentials -> InstanceId
instanceId = InstanceId Text
instanceId',
        pipelineStep :: SourceCredentials -> PipelineStep
pipelineStep = PipelineStep Text
pipelineStep',
        beamtime :: SourceCredentials -> Beamtime
beamtime = Beamtime Text
beamtime',
        beamline :: SourceCredentials -> Beamline
beamline = Beamline Text
beamline',
        dataSource :: SourceCredentials -> DataSource
dataSource = DataSource Text
dataSource',
        token :: SourceCredentials -> Token
token = Token Text
token'
      }
    )
  AsapoSourceCredentialsHandle -> IO a
f = do
    let convertSourceType :: SourceType -> AsapoBool
convertSourceType SourceType
RawSource = AsapoBool
kRaw
        convertSourceType SourceType
ProcessedSource = AsapoBool
kProcessed
        createCredentialsWithText :: IO AsapoSourceCredentialsHandle
createCredentialsWithText = Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
instanceId' \CString
instanceId'' -> Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
pipelineStep' \CString
pipelineStep'' -> Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
beamtime' \CString
beamtime'' -> Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
beamline' \CString
beamline'' -> Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
dataSource' \CString
dataSource'' ->
          Text
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a. Text -> (CString -> IO a) -> IO a
withText Text
token' ((CString -> IO AsapoSourceCredentialsHandle)
 -> IO AsapoSourceCredentialsHandle)
-> (CString -> IO AsapoSourceCredentialsHandle)
-> IO AsapoSourceCredentialsHandle
forall a b. (a -> b) -> a -> b
$
            AsapoBool
-> CString
-> CString
-> CString
-> CString
-> CString
-> CString
-> IO AsapoSourceCredentialsHandle
asapo_create_source_credentials
              (SourceType -> AsapoBool
convertSourceType SourceType
sourceType)
              CString
instanceId''
              CString
pipelineStep''
              CString
beamtime''
              CString
beamline''
              CString
dataSource''
    IO AsapoSourceCredentialsHandle
-> (AsapoSourceCredentialsHandle -> IO ())
-> (AsapoSourceCredentialsHandle -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO AsapoSourceCredentialsHandle
createCredentialsWithText AsapoSourceCredentialsHandle -> IO ()
asapo_free_source_credentials AsapoSourceCredentialsHandle -> IO a
f

peekCStringText :: CString -> IO Text
peekCStringText :: CString -> IO Text
peekCStringText = (String -> Text
pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO String -> IO Text)
-> (CString -> IO String) -> CString -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO String
peekCString

peekConstCStringText :: ConstPtr CChar -> IO Text
peekConstCStringText :: ConstPtr CChar -> IO Text
peekConstCStringText = (String -> Text
pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO String -> IO Text)
-> (ConstPtr CChar -> IO String) -> ConstPtr CChar -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO String
peekCString (CString -> IO String)
-> (ConstPtr CChar -> CString) -> ConstPtr CChar -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstPtr CChar -> CString
forall a. ConstPtr a -> Ptr a
unConstPtr

withConstCString :: String -> (ConstCString -> IO b) -> IO b
withConstCString :: forall b. String -> (ConstPtr CChar -> IO b) -> IO b
withConstCString String
s ConstPtr CChar -> IO b
f = String -> (CString -> IO b) -> IO b
forall a. String -> (CString -> IO a) -> IO a
withCString String
s (ConstPtr CChar -> IO b
f (ConstPtr CChar -> IO b)
-> (CString -> ConstPtr CChar) -> CString -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr)

withConstText :: Text -> (ConstCString -> IO a) -> IO a
withConstText :: forall a. Text -> (ConstPtr CChar -> IO a) -> IO a
withConstText Text
t = String -> (ConstPtr CChar -> IO a) -> IO a
forall b. String -> (ConstPtr CChar -> IO b) -> IO b
withConstCString (Text -> String
unpack Text
t)

withCStringN :: Int -> (CString -> IO a) -> IO a
withCStringN :: forall a. Int -> (CString -> IO a) -> IO a
withCStringN Int
size = IO CString -> (CString -> IO ()) -> (CString -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO CString
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
size) CString -> IO ()
forall a. Ptr a -> IO ()
free

withCStringNToText :: Int -> (CString -> IO ()) -> IO Text
withCStringNToText :: Int -> (CString -> IO ()) -> IO Text
withCStringNToText Int
size CString -> IO ()
f =
  Int -> (CString -> IO Text) -> IO Text
forall a. Int -> (CString -> IO a) -> IO a
withCStringN Int
size \CString
ptr -> do
    CString -> IO ()
f CString
ptr
    String -> Text
pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO String
peekCString CString
ptr

data StreamInfo = StreamInfo
  { StreamInfo -> MessageId
streamInfoLastId :: MessageId,
    StreamInfo -> StreamName
streamInfoName :: StreamName,
    StreamInfo -> Bool
streamInfoFinished :: Bool,
    StreamInfo -> Text
streamInfoNextStream :: Text,
    StreamInfo -> UTCTime
streamInfoCreated :: UTCTime,
    StreamInfo -> UTCTime
streamInfoLastEntry :: UTCTime
  }
  deriving (Int -> StreamInfo -> ShowS
[StreamInfo] -> ShowS
StreamInfo -> String
(Int -> StreamInfo -> ShowS)
-> (StreamInfo -> String)
-> ([StreamInfo] -> ShowS)
-> Show StreamInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StreamInfo -> ShowS
showsPrec :: Int -> StreamInfo -> ShowS
$cshow :: StreamInfo -> String
show :: StreamInfo -> String
$cshowList :: [StreamInfo] -> ShowS
showList :: [StreamInfo] -> ShowS
Show)

-- Thanks to
--
-- https://github.com/imoverclocked/convert-times/blob/7f9b45bea8e62dbf14a156a8229b68e07efec5a1/app/Main.hs
timespecToUTC :: TimeSpec -> UTCTime
timespecToUTC :: TimeSpec -> UTCTime
timespecToUTC TimeSpec
sc_time =
  let scEpochInUTC :: UTCTime
      scEpochInUTC :: UTCTime
scEpochInUTC = ZonedTime -> UTCTime
zonedTimeToUTC (ZonedTime -> UTCTime) -> ZonedTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Maybe ZonedTime -> ZonedTime
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ZonedTime -> ZonedTime) -> Maybe ZonedTime -> ZonedTime
forall a b. (a -> b) -> a -> b
$ String -> Maybe ZonedTime
forall t. TextualMonoid t => t -> Maybe ZonedTime
RFC3339.parseTimeRFC3339 String
"1970-01-01T00:00:00.00Z"
      sc2diffTime :: NominalDiffTime
sc2diffTime = Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (TimeSpec -> Integer
toNanoSecs TimeSpec
sc_time) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
1000000000 :: NominalDiffTime
   in NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
sc2diffTime UTCTime
scEpochInUTC

retrieveStreamInfoFromC :: AsapoStreamInfoHandle -> IO StreamInfo
retrieveStreamInfoFromC :: AsapoStreamInfoHandle -> IO StreamInfo
retrieveStreamInfoFromC AsapoStreamInfoHandle
infoHandle = do
  CULong
lastId <- AsapoStreamInfoHandle -> IO CULong
asapo_stream_info_get_last_id AsapoStreamInfoHandle
infoHandle
  Text
name <- AsapoStreamInfoHandle -> IO (ConstPtr CChar)
asapo_stream_info_get_name AsapoStreamInfoHandle
infoHandle IO (ConstPtr CChar) -> (ConstPtr CChar -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstPtr CChar -> IO Text
peekConstCStringText
  Text
nextStream <- AsapoStreamInfoHandle -> IO (ConstPtr CChar)
asapo_stream_info_get_next_stream AsapoStreamInfoHandle
infoHandle IO (ConstPtr CChar) -> (ConstPtr CChar -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstPtr CChar -> IO Text
peekConstCStringText
  AsapoBool
finished <- AsapoStreamInfoHandle -> IO AsapoBool
asapo_stream_info_get_finished AsapoStreamInfoHandle
infoHandle
  UTCTime
created <- (Ptr TimeSpec -> IO UTCTime) -> IO UTCTime
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr TimeSpec
timespecPtr -> do
    AsapoStreamInfoHandle -> Ptr TimeSpec -> IO ()
asapo_stream_info_get_timestamp_created AsapoStreamInfoHandle
infoHandle Ptr TimeSpec
timespecPtr
    TimeSpec
timespec <- Ptr TimeSpec -> IO TimeSpec
forall a. Storable a => Ptr a -> IO a
peek Ptr TimeSpec
timespecPtr
    UTCTime -> IO UTCTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeSpec -> UTCTime
timespecToUTC TimeSpec
timespec)
  UTCTime
lastEntry <- (Ptr TimeSpec -> IO UTCTime) -> IO UTCTime
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr TimeSpec
timespecPtr -> do
    AsapoStreamInfoHandle -> Ptr TimeSpec -> IO ()
asapo_stream_info_get_timestamp_last_entry AsapoStreamInfoHandle
infoHandle Ptr TimeSpec
timespecPtr
    TimeSpec
timespec <- Ptr TimeSpec -> IO TimeSpec
forall a. Storable a => Ptr a -> IO a
peek Ptr TimeSpec
timespecPtr
    UTCTime -> IO UTCTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeSpec -> UTCTime
timespecToUTC TimeSpec
timespec)
  StreamInfo -> IO StreamInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageId
-> StreamName -> Bool -> Text -> UTCTime -> UTCTime -> StreamInfo
StreamInfo (Word64 -> MessageId
MessageId (CULong -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULong
lastId)) (Text -> StreamName
StreamName Text
name) (AsapoBool
finished AsapoBool -> AsapoBool -> Bool
forall a. Ord a => a -> a -> Bool
> AsapoBool
0) Text
nextStream UTCTime
created UTCTime
lastEntry)

stringHandleToText :: AsapoStringHandle -> IO (Maybe Text)
stringHandleToText :: AsapoStringHandle -> IO (Maybe Text)
stringHandleToText handle :: AsapoStringHandle
handle@(AsapoStringHandle Ptr ()
handlePtr)
  | Ptr ()
handlePtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr = Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
  | Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AsapoStringHandle -> IO (ConstPtr CChar)
asapo_string_c_str AsapoStringHandle
handle IO (ConstPtr CChar) -> (ConstPtr CChar -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstPtr CChar -> IO Text
peekConstCStringText)

stringHandleToTextUnsafe :: AsapoStringHandle -> IO Text
stringHandleToTextUnsafe :: AsapoStringHandle -> IO Text
stringHandleToTextUnsafe = AsapoStringHandle -> IO (ConstPtr CChar)
asapo_string_c_str (AsapoStringHandle -> IO (ConstPtr CChar))
-> (ConstPtr CChar -> IO Text) -> AsapoStringHandle -> IO Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ConstPtr CChar -> IO Text
peekConstCStringText

withPtr :: (Storable a) => a -> (Ptr a -> IO b) -> IO (a, b)
withPtr :: forall a b. Storable a => a -> (Ptr a -> IO b) -> IO (a, b)
withPtr a
h Ptr a -> IO b
f = a -> (Ptr a -> IO (a, b)) -> IO (a, b)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with a
h \Ptr a
hPtr -> do
  b
result <- Ptr a -> IO b
f Ptr a
hPtr
  a
first <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
hPtr
  (a, b) -> IO (a, b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
first, b
result)