module Myxine.Direct
(
PageLocation, pagePort, PagePort, pagePath, PagePath
, Update(..), PageContent, pageBody, pageTitle, sendUpdate
, withEvents
, JavaScript(..), evaluateJs
, EventParseException(..)
,
) where
import Data.Maybe
import Data.Monoid
import Data.String
import Control.Monad
import Control.Concurrent
import Data.List
import Control.Exception
import Data.Dependent.Map (Some(..))
import qualified Data.ByteString.Lazy.Char8 as ByteString
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Aeson as JSON
import qualified Network.HTTP.Req as Req
import Network.HTTP.Types (ok200)
import Network.HTTP.Client (responseStatus, responseBody)
import Myxine.Event
import Myxine.Internal.EventStream
import Myxine.Target
data EventParseException
= TargetParseException String
| UnknownEventTypeException ByteString
| EventDataParseException ByteString String ByteString
deriving (Eq, Ord, Exception)
instance Show EventParseException where
show exn =
"*** Myxine client panic: Failed to parse " <> component <> "! This means one of:\n\n"
<> " 1) You connected to an event source that is not the Myxine server\n"
<> " 2) You connected to a Myxine server process with an incompatible major version\n"
<> " 3) There is a bug in the Myxine server or client library (totally possible!)\n\n"
<> " If you suspect it's (3), please file a bug report at:\n\n " <> bugReportURL <> "\n\n"
<> " Please include the version of this library, the version of the Myxine server,\n"
<> " and the following details:\n\n"
<> details
where
component, details, bugReportURL :: String
(component, details) = case exn of
TargetParseException input ->
("target path",
" - Unparseable target path: " <> show input)
UnknownEventTypeException eventType ->
("event type",
" - Unknown event type: " <> show eventType)
EventDataParseException eventType parseError badInput ->
("event properties",
" - Known event type: " <> show eventType <> "\n" <>
" - Parse error: " <> parseError <> "\n" <>
" - Bad input properties: " <> show badInput)
bugReportURL = "https://github.com/GaloisInc/myxine/issues/new"
data PageContent
= PageContent
{ pageContentBody :: Text
, pageContentTitle :: Last Text
} deriving (Eq, Ord, Show)
instance Semigroup PageContent where
PageContent body title <> PageContent body' title' =
PageContent (body <> body') (title <> title')
instance Monoid PageContent where
mempty = PageContent mempty mempty
pageBody :: Text -> PageContent
pageBody body = mempty { pageContentBody = body }
pageTitle :: Text -> PageContent
pageTitle title = mempty { pageContentTitle = Last (Just title) }
data Update
= Dynamic
PageContent
| Static
ByteString
ByteString
deriving (Eq, Ord, Show)
pageUrl :: PagePath -> Req.Url 'Req.Http
pageUrl (PagePath p) =
foldl' (Req./:) (Req.http "localhost") (Text.split ('/' ==) p)
newtype PagePort
= PagePort Int
deriving newtype (Num, Eq, Ord, Show)
newtype PagePath
= PagePath Text
deriving newtype (IsString, Eq, Ord, Show)
data PageLocation
= PageLocation
{ pageLocationPort :: Last PagePort
, pageLocationPath :: Last PagePath
} deriving (Eq, Ord, Show)
pagePath :: PagePath -> PageLocation
pagePath p = mempty { pageLocationPath = Last (Just p) }
pagePort :: PagePort -> PageLocation
pagePort p = mempty { pageLocationPort = Last (Just p) }
defaultPort :: Int
defaultPort = 1123
instance Semigroup PageLocation where
PageLocation port1 path1 <> PageLocation port2 path2 =
PageLocation (port1 <> port2) (path1 <> path2)
instance Monoid PageLocation where
mempty = PageLocation
{ pageLocationPort = mempty
, pageLocationPath = mempty }
sendUpdate ::
PageLocation ->
Update ->
IO ()
sendUpdate PageLocation{pageLocationPort = Last maybePort,
pageLocationPath = Last maybePath} update =
do _ <- Req.runReq Req.defaultHttpConfig $
Req.req Req.POST url body
Req.ignoreResponse (portOption <> params)
pure ()
where
url = pageUrl (fromMaybe "" maybePath)
portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)
body :: Req.ReqBodyLbs
params :: Req.Option 'Req.Http
(body, params) = case update of
Dynamic (PageContent{pageContentTitle = Last maybeTitle,
pageContentBody = text}) ->
( Req.ReqBodyLbs (ByteString.fromStrict (Text.encodeUtf8 text))
, foldMap ("title" Req.=:) maybeTitle )
Static contentType content ->
( Req.ReqBodyLbs content
, Req.header "Content-Type" (ByteString.toStrict contentType)
<> Req.queryFlag "static" )
data JavaScript
= JsExpression Text
| JsBlock Text
deriving (Eq, Ord, Show)
evaluateJs ::
JSON.FromJSON a =>
PageLocation ->
Maybe Int ->
JavaScript ->
IO (Either String a)
evaluateJs PageLocation{pageLocationPort = Last maybePort,
pageLocationPath = Last maybePath} timeout js =
do result <- Req.runReq Req.defaultHttpConfig $
Req.req Req.POST url body Req.lbsResponse
(portOption <> timeoutOption <> exprOption)
pure if Req.responseStatusCode result == 200
then JSON.eitherDecode (Req.responseBody result)
else Left (ByteString.unpack (Req.responseBody result))
where
url = pageUrl (fromMaybe "" maybePath)
portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)
body :: Req.ReqBodyLbs
exprOption, timeoutOption :: Req.Option 'Req.Http
timeoutOption = foldMap ("timeout" Req.=:) timeout
(body, exprOption) = case js of
JsExpression expr ->
(Req.ReqBodyLbs "", "evaluate" Req.=: expr)
JsBlock block ->
(Req.ReqBodyLbs (ByteString.fromStrict (Text.encodeUtf8 block)),
Req.queryFlag "evaluate")
withEvents ::
PageLocation
->
Maybe [Some EventType]
->
(forall d. EventType d -> d -> [Target] -> IO ())
->
IO ()
withEvents _ (Just []) _ =
forever (threadDelay maxBound)
withEvents PageLocation{pageLocationPort = Last maybePort,
pageLocationPath = Last maybePath} events perEvent =
do withStreamEvents url
(portOption <> eventParams)
\StreamEvent{eventId, eventType, eventData} -> do
targets <- either (throwIO . TargetParseException)
pure (JSON.eitherDecode eventId)
withParsedEvent eventType eventData \case
Left Nothing -> throwIO (UnknownEventTypeException eventType)
Left (Just err) -> throwIO (EventDataParseException eventType err eventData)
Right (eventTy, properties) ->
perEvent eventTy properties targets
where
url = pageUrl (fromMaybe "" maybePath)
portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)
eventParams :: Req.Option 'Req.Http
eventParams = case events of
Nothing -> Req.queryFlag "events"
Just es -> flip foldMap es
\(Some e) -> "event" Req.=: ByteString.unpack (encodeEventType e)
withParsedEvent ::
ByteString -> ByteString -> (forall d. Either (Maybe String) (EventType d, d) -> r) -> r
withParsedEvent name properties k =
case decodeSomeEventType name of
Nothing -> k (Left Nothing)
Just (Some t) -> case decodeEventProperties t properties of
Left err -> k (Left (Just err))
Right p -> k (Right (t, p))
withStreamEvents ::
Req.Url scheme -> Req.Option scheme -> (StreamEvent -> IO ()) -> IO ()
withStreamEvents url options withEvent =
Req.runReq Req.defaultHttpConfig $ Req.reqBr Req.GET url Req.NoReqBody options
\response ->
if responseStatus response /= ok200
then pure ()
else do
let nextChunk = ByteString.fromStrict <$> responseBody response
nextLine <- linesFromChunks nextChunk
nextEvent <- eventsFromLines nextLine
let loop = do
maybeEvent <- nextEvent
maybe (pure ()) (\e -> withEvent e >> loop) maybeEvent
loop