diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Connor Moreside (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Connor Moreside nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lightning-haskell.cabal b/lightning-haskell.cabal new file mode 100644 --- /dev/null +++ b/lightning-haskell.cabal @@ -0,0 +1,104 @@ +name: lightning-haskell +version: 0.1.0.2 +synopsis: Haskell client for lightning-viz REST API +description: Please see README.md +homepage: https://github.com/cmoresid/lightning-haskell#readme +license: BSD3 +license-file: LICENSE +author: Connor Moreside +maintainer: connor@moresi.de +copyright: 2016 Connor Moreside +stability: experimental +category: Web, Visualization +tested-with: GHC == 7.10.3, GHC == 8.0.1 +build-type: Simple +cabal-version: >=1.10 +description: + A Haskell client for lightning-viz server. + +library + hs-source-dirs: src + exposed-modules: Web.Lightning + , Web.Lightning.Session + , Web.Lightning.Plots + , Web.Lightning.Render + , Web.Lightning.Types + , Web.Lightning.Types.Lightning + , Web.Lightning.Types.Error + , Web.Lightning.Types.Visualization + , Web.Lightning.Utilities + other-modules: Web.Lightning.Routes + , Web.Lightning.Plots.Line + , Web.Lightning.Plots.Force + , Web.Lightning.Plots.Scatter + , Web.Lightning.Plots.Matrix + , Web.Lightning.Plots.Adjacency + , Web.Lightning.Plots.Map + , Web.Lightning.Plots.Circle + , Web.Lightning.Plots.Histogram + , Web.Lightning.Plots.Graph + , Web.Lightning.Plots.GraphBundled + , Web.Lightning.Plots.Scatter3 + , Web.Lightning.Types.Session + , Web.Lightning.Plots.LineStream + , Web.Lightning.Plots.ScatterStream + , Web.Lightning.Plots.Volume + build-depends: base >= 4.7 && < 5 + , aeson >= 0.11.2.0 && < 1.0.0.0 + , blaze-html >= 0.8.1.2 + , bytestring >= 0.10.6.0 + , data-default-class >= 0.0.1 + , free >= 4.12.0 + , mtl >= 2.2.0 + , http-client >= 0.4.0 + , http-client-tls >= 0.2.4.0 + , http-types >= 0.9.1 + , network >= 2.6.2.0 + , text >= 1.2.2.0 + , transformers >= 0.4.0.0 + , api-builder == 0.12.* + ghc-options: -Wall + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , lightning-haskell + , aeson >= 0.11.2.0 && < 1.0.0.0 + , api-builder == 0.12.* + , bytestring >= 0.10.6.0 + , hspec >= 2.2.0 + , text >= 1.2.2.0 + , transformers >= 0.4.0.0 + other-modules: Web.LightningSpec + , Web.Lightning.Types.PlotsSpec + , Web.Lightning.UtilitySpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +test-suite test-integration + type: exitcode-stdio-1.0 + hs-source-dirs: test-integration + main-is: Spec.hs + build-depends: base + , lightning-haskell + , aeson >= 0.11.2.0 && < 1.0.0.0 + , http-client >= 0.4.0 + , http-client-tls >= 0.2.4.0 + , http-types >= 0.9.1 + , network >= 2.6.2.0 + , api-builder == 0.12.* + , bytestring >= 0.10.6.0 + , hspec >= 2.2.0 + , text >= 1.2.2.0 + , transformers >= 0.4.0.0 + other-modules: ConfigLightning + , Web.Lightning.PlotSpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/cmoresid/lightning-haskell diff --git a/src/Web/Lightning.hs b/src/Web/Lightning.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning +Description : lightning-viz REST API wrapper. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX +-} + +module Web.Lightning + ( + -- * Lightning Types + LoginMethod(..) + , LightningOptions(..) + , LightningState(..) + -- * Execute + , runLightning + , runLightningWith + , runResumeLightningtWith + , interpretIO + -- * Client configuration + , defaultLightningOptions + , setBaseURL + , setSessionName + , setSessionId + , setBasicAuth + -- * Re-exports + , APIError(..) + , module Web.Lightning.Types.Error + , module Web.Lightning.Types.Lightning + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class +import Control.Monad.Trans.Free +import Control.Monad.Trans.Reader + +import Data.Aeson +import qualified Data.ByteString as B +import Data.Default.Class +import qualified Data.Text as T + +import Web.Lightning.Session +import Web.Lightning.Types.Error +import Web.Lightning.Types.Lightning +import Web.Lightning.Utilities + +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +import Network.API.Builder as API +-------------------------------------------------------------------------------- + +-- | Represents the different authentication mechanisms available in +-- the lightning-viz server. +data LoginMethod = Anonymous -- ^ No authentication required + | BasicAuth Credentials -- ^ HTTP Basic Authentication + deriving (Show) + +{- | Username and password pair for authenticating to the lightning-viz server. -} +type Credentials = (B.ByteString, B.ByteString) + +instance Default LoginMethod where + def = Anonymous + +-- | Defines the available options for running a lightning action(s). +data LightningOptions = + LightningOptions { optConnManager :: Maybe Manager + -- ^ Re-usable connection manager used during Lightning + -- session. + , optHostUrl :: T.Text + -- ^ The base lightning-viz server url. + , optLoginMethod :: LoginMethod + -- ^ The authentication mechanism used to communicate + -- with the lightning-viz server. + , optSession :: Maybe Session + -- ^ Defines what session to use when creating viaualizations + -- on the lightning-viz server. If no session is specified, + -- one will be created automatically. + } + +instance Default LightningOptions where + def = LightningOptions Nothing defaultBaseURL Anonymous Nothing + +-- | Defines the default lightning-viz options. +defaultLightningOptions :: LightningOptions +defaultLightningOptions = def + +-- | Sets the base URL of Lightning's API in the given +-- 'LightningOptions' record. +setBaseURL :: T.Text + -- ^ Fully qualified API base URL + -> LightningOptions + -> LightningOptions +setBaseURL url opts = opts { optHostUrl = url } + +-- | Sets the name of the session that is nested in the +-- given 'LightningOptions' record. +setSessionName :: T.Text + -- ^ The new session name + -> LightningOptions + -> LightningOptions +setSessionName n opts@(LightningOptions _ _ _ s) = + opts { optSession = Just sess } + where + sess = + case s of + Nothing -> def { snName = Just n } + Just s' -> s' { snName = Just n } + +-- | Sets the session ID of the session nested in the given +-- 'LightningOptions' record. +setSessionId :: T.Text + -- ^ The new session ID + -> LightningOptions + -> LightningOptions +setSessionId i opts@(LightningOptions _ _ _ s) = + opts { optSession = Just sess } + where + sess = + case s of + Nothing -> def { snId = i } + Just s' -> s' { snId = i } + +-- | Sets 'BasicAuth' with 'Credentials' as the login method in the +-- given 'LightningOptions' record. +setBasicAuth :: Credentials -> LightningOptions -> LightningOptions +setBasicAuth creds opts = opts { optLoginMethod = BasicAuth creds } + +-- | Performs a lightning action (or 'LightningT' transformer actions) with the +-- default lightning options. By default, the lightning-viz server is assumed to +-- be running on http://localhost:3000 and a new session will be created. +runLightning :: MonadIO m + => LightningT m a + -> m (Either (APIError LightningError) a) +runLightning = runLightningWith defaultLightningOptions + +-- | Performs a lightning action (or 'LightningT' transformer actions) with +-- the specified lightning options. +runLightningWith :: MonadIO m => LightningOptions + -> LightningT m a + -> m (Either (APIError LightningError) a) +runLightningWith opts lightning = + dropResume <$> runResumeLightningtWith opts lightning + +-- | Runs a specified series of lightning actions. +interpretIO :: MonadIO m => LightningState + -> LightningT m a + -> m (Either (APIError LightningError, Maybe (LightningT m a)) a) +interpretIO lstate@(LightningState url _ _ _) (LightningT r) = + runFreeT (runReaderT r url) >>= \case + Pure x -> return $ Right x + Free (WithBaseURL u x n) -> + interpretIO (lstate { stCurrentBaseURL = u }) x >>= \case + Left (err, Just resume) -> + return $ Left (err, Just $ resume >>= LightningT . liftLightningF . n) + Left (err, Nothing) -> return $ Left (err, Nothing) + Right res -> interpretIO lstate $ LightningT $ (liftLightningF . n) res + Free (FailWith x) -> return $ Left (x, Nothing) + Free (RunRoute route n) -> + interpretIO lstate $ LightningT $ wrap $ ReceiveRoute route (liftLightningF . n . unwrapJSON) + Free (SendJSON jsonObj route n) -> + handleSendJSON route lstate jsonObj >>= \case + Left err -> return $ Left (err, Just $ LightningT $ wrap $ SendJSON jsonObj route (liftLightningF . n)) + Right x -> interpretIO lstate $ LightningT $ (liftLightningF . n) x + Free (ReceiveRoute route n) -> + handleReceive route lstate >>= \case + Left err -> return $ Left (err, Just $ LightningT $ wrap $ ReceiveRoute route (liftLightningF . n)) + Right x -> interpretIO lstate $ LightningT $ (liftLightningF . n) x + +-- | Runs a lightning action using the specified options. +runResumeLightningtWith :: MonadIO m => LightningOptions + -> LightningT m a + -> m (Either (APIError LightningError, Maybe (LightningT m a)) a) +runResumeLightningtWith (LightningOptions cm hu lm s) lightning = do + manager <- case cm of + Just m -> return m + Nothing -> liftIO $ newManager tlsManagerSettings + auth <- case lm of + Anonymous -> return id + BasicAuth creds -> return $ uncurry applyBasicAuth creds + session <- case s of + Just s' -> + case snId s' of + "" -> (fmap . fmap) Just $ + interpretIO (LightningState hu manager Nothing auth) $ createSession $ snName s' + _ -> return $ Right $ Just s' + Nothing -> (fmap . fmap) Just $ + interpretIO (LightningState hu manager Nothing auth) $ createSession Nothing + case session of + Left (err, _) -> return $ Left (err, Just lightning) + Right s' -> + interpretIO (LightningState hu manager s' auth) lightning + +-- | Runs the specified route using the current state. +handleReceive :: (MonadIO m, Receivable a) => Route + -> LightningState + -> m (Either (APIError LightningError) a) +handleReceive r lstate = do + (res, _, _) <- runAPI (builderFromState lstate) (stConnManager lstate) () $ + API.runRoute r + + return res + +-- | Runs the specified route and sends the specified JSON value as the the +-- request body. +handleSendJSON :: (MonadIO m, Receivable a) => Route + -> LightningState + -> Value + -> m (Either (APIError LightningError) a) +handleSendJSON r lstate p = do + (res, _, _) <- runAPI (builderFromState lstate) (stConnManager lstate) () $ + API.sendRoute p r + + return res + +-- | Creates a 'Builder' record to keep track of the lightning-viz server's +-- name and base URL. +builderFromState :: LightningState + -> Builder +builderFromState (LightningState hurl _ (Just s) auth) = + Builder "Lightning" (addSessionId hurl (snId s)) id auth +builderFromState (LightningState hurl _ Nothing auth) = + Builder "Lightning" hurl id auth + +-- | Unwraps the response from interpretIO. +dropResume :: Either (APIError LightningError, Maybe (LightningT m a)) a + -> Either (APIError LightningError) a +dropResume (Left (x, _)) = Left x +dropResume (Right x) = Right x + +-- | Stores the current state of the lightning transformer stack. +data LightningState = + LightningState { stCurrentBaseURL :: T.Text + -- ^ Current base URL of the lightning-viz server. + , stConnManager :: Manager + -- ^ Current connection manager used to run actions. + , stSession :: Maybe Session + -- ^ The current lightning session to run actions against. + , stApplyAuth :: Request -> Request + -- ^ Hook to add auth credentials on performing a request + -- to the lightning-viz sever. + } diff --git a/src/Web/Lightning/Plots.hs b/src/Web/Lightning/Plots.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots.hs @@ -0,0 +1,74 @@ +{-| +Module : Web.Lightning.Plots +Description : Lightning Plots +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX +-} + +module Web.Lightning.Plots + ( + -- * Sparse Adjacency Matrix + AdjacencyPlot(..) + , adjacencyPlot + -- * Force-Directed Network + , ForcePlot(..) + , forcePlot + -- * Graph + , GraphPlot(..) + , graphPlot + -- * Graph Bundled + , graphBundledPlot + -- * Line + , LinePlot(..) + , linePlot + -- * Map + , MapPlot(..) + , mapPlot + -- * Matrix + , MatrixPlot(..) + , matrixPlot + -- * Scatter + , ScatterPlot(..) + , scatterPlot + -- * 3D Scatter + , Scatter3Plot(..) + , scatter3Plot + -- * Circle + , CirclePlot(..) + , circlePlot + -- * Histogram + , HistogramPlot(..) + , histogramPlot + -- * Volume + , VolumePlot(..) + , volumePlot + -- * Streaming Line Plot + , LineStreamPlot(..) + , streamingLinePlot + -- * Streaming Scatter Plot + , ScatterStreamPlot(..) + , streamingScatterPlot + + , module Data.Default.Class + ) + where + +import Data.Default.Class + +import Web.Lightning.Plots.Adjacency +import Web.Lightning.Plots.Force +import Web.Lightning.Plots.Graph +import Web.Lightning.Plots.GraphBundled +import Web.Lightning.Plots.Line +import Web.Lightning.Plots.Map +import Web.Lightning.Plots.Matrix +import Web.Lightning.Plots.Circle +import Web.Lightning.Plots.Histogram +import Web.Lightning.Plots.Scatter +import Web.Lightning.Plots.Scatter3 +import Web.Lightning.Plots.LineStream +import Web.Lightning.Plots.ScatterStream +import Web.Lightning.Plots.Volume diff --git a/src/Web/Lightning/Plots/Adjacency.hs b/src/Web/Lightning/Plots/Adjacency.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Adjacency.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a sparse adjacency matrix. +module Web.Lightning.Plots.Adjacency + ( + AdjacencyPlot(..) + , Visualization (..) + , adjacencyPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Adjacency plot parameters +data AdjacencyPlot = + AdjacencyPlot { apConn :: [[Double]] + -- ^ Matrix that defines the connectivity of the plot. The + -- dimensions of the matrix can be (n, n), (n, 2) or (n, 3). + -- Matrix can be binary or continuous valued. Links should + -- contain either 2 elements per link (source, target) or + -- 3 elements (source, target, value). + , apLabels :: Maybe [T.Text] + -- ^ Text labels for each item (will label rows and columns). + , apGroup :: Maybe [Int] + -- ^ List to set colors via groups. + , apSort :: Maybe T.Text + -- ^ What to sort by; options are "group" or "degree." + , apNumbers :: Maybe Bool + -- ^ Whether or not to show numbers on cells. + , apSymmetric :: Maybe Bool + -- ^ Whether or not to make links symetrical. + } + deriving (Show, Eq) + +instance Default AdjacencyPlot where + def = AdjacencyPlot [[]] Nothing Nothing (Just "group") (Just False) (Just True) + +instance ToJSON AdjacencyPlot where + toJSON (AdjacencyPlot conn lbs grps srt nbrs sym) = + omitNulls [ "links" .= getLinks conn + , "nodes" .= getNodes conn + , "labels" .= lbs + , "group" .= grps + , "numbers" .= nbrs + , "symmetric" .= sym + , "srt" .= srt + ] + +instance ValidatablePlot AdjacencyPlot where + validatePlot (AdjacencyPlot conn lbls grp srt nbrs sym) = do + conn' <- validateConn conn + return $ AdjacencyPlot conn' lbls grp srt nbrs sym + +-- | Submits a request to the specified lightning-viz server to create +-- a sparse adjacency matrix visualiazation. +-- +-- +adjacencyPlot :: Monad m => AdjacencyPlot + -- ^ Adjacency plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +adjacencyPlot adjPlt = do + url <- ask + viz <- sendPlot "adjacency" adjPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Circle.hs b/src/Web/Lightning/Plots/Circle.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Circle.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize spatial points as a scatter plot. +module Web.Lightning.Plots.Circle + ( CirclePlot(..) + , Visualization (..) + , circlePlot + ) where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Circle plot parameters +data CirclePlot = + CirclePlot { + cpConn :: [[Double]] + -- ^ Matrix that defines the connectivity of the plot. The + -- dimensions of the matrix can be (n, n), (n, 2) or (n, 3). + -- Matrix can be binary or continuous valued. Links should + -- contain either 2 elements per link (source, target) or + -- 3 elements (source, target, value). + , cpGroup :: Maybe [Int] + -- ^ List to set colors via groups. + , cpColor :: Maybe [Int] + -- ^ (k, 3) : List of rbg values to set colors of top-level + -- group, where k is the number of unique elements in the + -- top-level group. + , cpLabels :: Maybe [T.Text] + -- ^ List of text labels to label nodes. + } + deriving (Show, Eq) + +instance Default CirclePlot where + def = CirclePlot [[]] Nothing Nothing Nothing + +instance ToJSON CirclePlot where + toJSON (CirclePlot conn gs cs ls) = + omitNulls [ "links" .= getLinks conn + , "nodes" .= getNodes conn + , "group" .= gs + , "color" .= cs + , "labels" .= ls + ] + +instance ValidatablePlot CirclePlot where + validatePlot (CirclePlot conn grp cs lbl) = do + conn' <- validateConn conn + cs' <- validateColor cs + return $ CirclePlot conn' grp cs' lbl + +-- | Submits a request to the specified lightning-viz server to create +-- a circular graph from connectivity data. +-- +-- +circlePlot :: Monad m => CirclePlot + -- ^ Circle plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +circlePlot circlePlt = do + url <- ask + viz <- sendPlot "circle" circlePlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Force.hs b/src/Web/Lightning/Plots/Force.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Force.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a force-directed network from connectivity. +module Web.Lightning.Plots.Force + ( + ForcePlot(..) + , Visualization (..) + , forcePlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Force plot parameters +data ForcePlot = + ForcePlot { fpConn :: [[Double]] + -- ^ Matrix that defines the connectivity of the plot. The + -- dimensions of the matrix can be (n, n), (n, 2) or (n, 3). + -- Matrix can be binary or continuous valued. Links should + -- contain either 2 elements per link (source, target) or + -- 3 elements (source, target, value). + , fpValues :: Maybe [Double] + -- ^ Values to set node colors via a linear scale. + , fpLabels :: Maybe [T.Text] + -- ^ List of text labels to set as tooltips. + , fpColor :: Maybe [Int] + -- ^ Single RGB value or list to set node colors. + , fpGroup :: Maybe [Int] + -- ^ Single integer or list to set node colors via groups. + , fpColorMap :: Maybe T.Text + -- ^ Specification of color map, only colorbrewer types supported. + , fpSize :: Maybe [Int] + -- ^ Single size or list to set node sizes. + , fpToolTips :: Maybe Bool + -- ^ Whether or not to show tooltips. + , fpZoom :: Maybe Bool + -- ^ Whether or not to allow zooming. + , fpBrush :: Maybe Bool + -- ^ Whether or not to support brushing. + } + deriving (Show, Eq) + +instance Default ForcePlot where + def = ForcePlot [[]] Nothing Nothing Nothing Nothing Nothing + Nothing (Just True) (Just True) (Just True) + +instance ToJSON ForcePlot where + toJSON (ForcePlot conn vs lbs cs gs cm ss tt z b) = + omitNulls [ "links" .= getLinks conn + , "nodes" .= getNodes conn + , "values" .= vs + , "labels" .= lbs + , "color" .= cs + , "group" .= gs + , "colormap" .= cm + , "size" .= ss + , "tooltips" .= tt + , "zoom" .= z + , "brush" .= b + ] + +instance ValidatablePlot ForcePlot where + validatePlot (ForcePlot conn vl lbl c grp cm s tt z b) = do + conn' <- validateConn conn + c' <- validateColor c + cm' <- validateColorMap cm + s' <- validateSize s + return $ ForcePlot conn' vl lbl c' grp cm' s' tt z b + +-- | Submits a request to the specified lightning-viz server to create a +-- force-directed network visualization from connectivity. +-- +-- +forcePlot :: Monad m => ForcePlot + -- ^ Force plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +forcePlot forcePlt = do + url <- ask + viz <- sendPlot "force" forcePlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Graph.hs b/src/Web/Lightning/Plots/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Graph.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize graph structure. +module Web.Lightning.Plots.Graph + ( + GraphPlot(..) + , Visualization (..) + , graphPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Graph plot parameters +data GraphPlot = + GraphPlot { gpX :: [Double] + -- ^ x-points for node co-ordinates. + , gpY :: [Double] + -- ^ y-points for node co-ordinates. + , gpConn :: [[Double]] + -- ^ Matrix that defines the connectivity of the plot. The + -- dimensions of the matrix can be (n, n), (n, 2) or (n, 3). + -- Matrix can be binary or continuous valued. Links should + -- contain either 2 elements per link (source, target) or + -- 3 elements (source, target, value). + , gpValues :: Maybe [Int] + -- ^ Values to set node colors via a linear scale. + , gpLabels :: Maybe [T.Text] + -- ^ List of text labels to be used as tooltips. + , gpColors :: Maybe [Int] + -- ^ List to set node colors. + , gpGroup :: Maybe [Int] + -- ^ List to set node colors via group assignment. + , gpColorMap :: Maybe T.Text + -- ^ Specification of color map; only colorbrewer types supported. + , gpSize :: Maybe [Int] + -- ^ List to set node sizes. + , gpToolTips :: Maybe Bool + -- ^ Whether or not to show tooltips. + , gpZoom :: Maybe Bool + -- ^ Whether or not to allow zooming. + , gpBrush :: Maybe Bool + -- ^ Whether or not to support brushing. + } + deriving (Show, Eq) + +instance Default GraphPlot where + def = GraphPlot [] [] [[]] Nothing Nothing Nothing Nothing Nothing + Nothing (Just True) (Just True) (Just True) + +instance ToJSON GraphPlot where + toJSON (GraphPlot xs ys conn vs ls cs gs cm ss t z b) = + omitNulls [ "links" .= getLinks conn + , "nodes" .= getPoints xs ys + , "values" .= vs + , "labels" .= ls + , "color" .= cs + , "group" .= gs + , "colormap" .= cm + , "size" .= ss + , "tooltips" .= t + , "zoom" .= z + , "brush" .= b + ] + +instance ValidatablePlot GraphPlot where + validatePlot (GraphPlot xs ys conn vl lbl c g cm s tt z b) = do + (xs', ys') <- validateCoordinates xs ys + conn' <- validateConn conn + c' <- validateColor c + cm' <- validateColorMap cm + s' <- validateSize s + return $ GraphPlot xs' ys' conn' vl lbl c' g cm' s' tt z b + +-- | Submits a request to the specified lightning-viz server to create a +-- node-link graph from spatial points and their connectivity. +graphPlot :: Monad m => GraphPlot + -- ^ Graph plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +graphPlot graphPlt = do + url <- ask + viz <- sendPlot "graph" graphPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/GraphBundled.hs b/src/Web/Lightning/Plots/GraphBundled.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/GraphBundled.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a bundled node-link graph. +module Web.Lightning.Plots.GraphBundled + ( + GraphPlot(..) + , Visualization(..) + , graphBundledPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Plots.Graph (GraphPlot(..)) +import Web.Lightning.Types.Lightning (LightningT, sendPlot) +import Web.Lightning.Types.Visualization (Visualization (..)) +-------------------------------------------------------------------------------- + +-- | Submits a request to the specified lightning-viz server to create a +-- bundled node-link graph visualization. +graphBundledPlot :: Monad m => GraphPlot + -- ^ Graph plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +graphBundledPlot graphPlt = do + url <- ask + viz <- sendPlot "graph-bundled" graphPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Histogram.hs b/src/Web/Lightning/Plots/Histogram.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Histogram.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize one-dimensional series data as lines. +module Web.Lightning.Plots.Histogram + ( + HistogramPlot(..) + , Visualization (..) + , histogramPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Histogram plot parameters +data HistogramPlot = + HistogramPlot { hpValues :: [Double] + , hpBins :: Maybe [Double] + , hpZoom :: Maybe Bool + } + deriving (Show, Eq) + +instance Default HistogramPlot where + def = HistogramPlot [] Nothing (Just True) + +instance ToJSON HistogramPlot where + toJSON (HistogramPlot vs bs z) = + omitNulls [ "values" .= vs + , "bins" .= bs + , "zoom" .= z + ] + +instance ValidatablePlot HistogramPlot where + validatePlot (HistogramPlot v b z) = do + b' <- validateBin b + return $ HistogramPlot v b' z + +-- | Submits a request to the specified lightning-viz server to create a plot +-- to histogram. +-- +-- +histogramPlot :: Monad m => HistogramPlot + -- ^ Histogram plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +histogramPlot histPlt = do + url <- ask + viz <- sendPlot "histogram" histPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Line.hs b/src/Web/Lightning/Plots/Line.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Line.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize one-dimensional series data as lines. +module Web.Lightning.Plots.Line + ( + LinePlot(..) + , Visualization (..) + , linePlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Line plot parameters +data LinePlot = + LinePlot { lpSeries :: [[Double]] + -- ^ Input data for line plot, typically n series of lenght m. Can + -- also pass a list where each individual series is of different + -- lengths. + , lpIndex :: Maybe [Int] + -- ^ Specify the index for the x-axis line plot. + , lpColor :: Maybe [Int] + -- ^ Single RGB value or list to set line colors to. + , lpGroup :: Maybe [Int] + -- ^ Single integer or list to set line colors to via group + -- assignment. + , lpThickness :: Maybe [Int] + -- ^ Single integer or list to set line thickness to. + , lpXaxis :: Maybe T.Text + -- ^ Label for x-axis. + , lpYaxis :: Maybe T.Text + -- ^ Label for y-axis. + , lpZoom :: Maybe Bool + -- ^ Whether or not to allow zooming. + } + deriving (Show, Eq) + +instance Default LinePlot where + def = LinePlot [[]] Nothing Nothing Nothing Nothing Nothing Nothing (Just True) + +instance ToJSON LinePlot where + toJSON (LinePlot ss is cs gs t xa ya z) = + omitNulls [ "series" .= ss + , "index" .= is + , "color" .= cs + , "group" .= gs + , "thickness" .= t + , "xaxis" .= xa + , "yaxis" .= ya + , "zoom" .= z + ] + +instance ValidatablePlot LinePlot where + validatePlot (LinePlot s i c g t xa ya z) = do + i' <- validateIndex i + c' <- validateColor c + t' <- validateThickness t + return $ LinePlot s i' c' g t' xa ya z + +-- | Submits a request to the specified lightning-viz server to create a plot +-- to visualize one-dimensional series. +-- +-- +linePlot :: Monad m => LinePlot + -- ^ Line plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +linePlot linePlt = do + url <- ask + viz <- sendPlot "line" linePlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/LineStream.hs b/src/Web/Lightning/Plots/LineStream.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/LineStream.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize one-dimensional series data as lines. +module Web.Lightning.Plots.LineStream + ( + LineStreamPlot(..) + , Visualization (..) + , streamingLinePlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Streaming line plot parameters +data LineStreamPlot = + LineStreamPlot { lspSeries :: [[Double]] + -- ^ Input data for line plot, typically n series of lenght m. Can + -- also pass a list where each individual series is of different + -- lengths. + , lspIndex :: Maybe [Int] + -- ^ Specify the index for the x-axis line plot. + , lspColor :: Maybe [Int] + -- ^ Single RGB value or list to set line colors to. + , lspGroup :: Maybe [Int] + -- ^ Single integer or list to set line colors to via group + -- assignment. + , lspSize :: Maybe [Int] + -- ^ Sets the line thickness + , lspXAxis :: Maybe T.Text + -- ^ Label for the x axis + , lspYAxis :: Maybe T.Text + -- ^ Label for the y axis + , lspMaxWidth :: Maybe Int + -- ^ The maximum number of time points to show before plot shifts. + , lspZoom :: Maybe Bool + -- ^ Whether or not to enable zooming. + , lspVisualization :: Maybe Visualization + } + deriving (Show) + +instance Default LineStreamPlot where + def = LineStreamPlot [[]] Nothing Nothing Nothing Nothing + Nothing Nothing Nothing (Just True) Nothing + +instance ToJSON LineStreamPlot where + toJSON (LineStreamPlot ss is cs gs t xa ya mw z _) = + omitNulls [ "series" .= ss + , "index" .= is + , "color" .= cs + , "group" .= gs + , "size" .= t + , "xaxis" .= xa + , "yaxis" .= ya + , "max_width" .= mw + , "zoom" .= z + ] + +instance ValidatablePlot LineStreamPlot where + validatePlot (LineStreamPlot ss i c g s xa ya mw z viz) = do + i' <- validateIndex i + c' <- validateColor c + s' <- validateSize s + return $ LineStreamPlot ss i' c' g s' xa ya mw z viz + +-- | Plot streaming one-dimensional series data as updating lines. +-- +-- +streamingLinePlot :: Monad m => LineStreamPlot + -- ^ Line plot to create / update. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +streamingLinePlot slp = do + url <- ask + viz <- streamPlot (lspVisualization slp) "line-streaming" slp R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Map.hs b/src/Web/Lightning/Plots/Map.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Map.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a chlorpleth map of the world or united states. +module Web.Lightning.Plots.Map + ( + MapPlot(..) + , Visualization (..) + , mapPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Map plot parameters +data MapPlot = + MapPlot { mppRegions :: [T.Text] + -- ^ String identifies for map regions, either length of two + -- characters (for states in a US map) or length of three + -- (for counties in a world map). + , mppWeights :: [Double] + -- ^ Values to use to color each reason + , mppColorMap :: Maybe T.Text + -- ^ Specification of color map; only colorbrew types supported. + } + deriving (Show, Eq) + +instance Default MapPlot where + def = MapPlot [] [] Nothing + +instance ToJSON MapPlot where + toJSON (MapPlot rs vs cm) = + omitNulls [ "regions" .= rs + , "values" .= vs + , "colormap" .= cm + ] + +instance ValidatablePlot MapPlot where + validatePlot (MapPlot r v cm) = do + r' <- validateRegion r + cm' <- validateColorMap cm + return $ MapPlot r' v cm' + +-- | Submits a request to the specified lightning-viz server to create a +-- chloropleth map of the world or united states. +-- +-- +mapPlot :: Monad m => MapPlot + -- ^ Map plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +mapPlot mapPlt = do + url <- ask + viz <- sendPlot "map" mapPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Matrix.hs b/src/Web/Lightning/Plots/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Matrix.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a dense matrix or table as a heat map. +module Web.Lightning.Plots.Matrix + ( + MatrixPlot(..) + , Visualization (..) + , matrixPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Matrix plot parameters +data MatrixPlot = + MatrixPlot { mpMatrix :: [[Double]] + -- ^ Two-dimensional list of matrix data. + , mpRowLabels :: Maybe [T.Text] + -- ^ List of strings to label rows. + , mpColLabels :: Maybe [T.Text] + -- ^ List of strings to label columns. + , mpColorMap :: Maybe T.Text + -- ^ Specification of color map; only colorbrewer types supported. + , mpNumbers :: Maybe Bool + -- ^ Whether or not to show numbers on the cells. + } + deriving (Show, Eq) + +instance Default MatrixPlot where + def = MatrixPlot [[]] Nothing Nothing Nothing (Just False) + +instance ToJSON MatrixPlot where + toJSON (MatrixPlot m rls cls cm nbrs) = + omitNulls [ "matrix" .= m + , "rowLabels" .= rls + , "colLabels" .= cls + , "colormap" .= cm + , "numbers" .= nbrs + ] + +instance ValidatablePlot MatrixPlot where + validatePlot (MatrixPlot mtx rlbl clbl cm nbr) = do + mtx' <- validateConn mtx + cm' <- validateColorMap cm + return $ MatrixPlot mtx' rlbl clbl cm' nbr + +-- | Submits a request to the specified lightning-viz server to create a +-- heat map of the given matrix. +-- +-- +matrixPlot :: Monad m => MatrixPlot + -- ^ Matrix plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +matrixPlot matrixPlt = do + url <- ask + viz <- sendPlot "matrix" matrixPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Scatter.hs b/src/Web/Lightning/Plots/Scatter.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Scatter.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize spatial points as a scatter plot. +module Web.Lightning.Plots.Scatter + ( + ScatterPlot(..) + , Visualization (..) + , scatterPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Scatter plot parameters +data ScatterPlot = + ScatterPlot { spX :: [Double] + -- ^ List of x points. + , spY :: [Double] + -- ^ List of y points. + , spValues :: Maybe [Double] + -- ^ Values to set node colors via a linear scale. + , spLabels :: Maybe [T.Text] + -- ^ List of text labels to set tooltips. + , spColor :: Maybe [Int] + -- ^ List of rgb values to set colors. + , spGroup :: Maybe [Int] + -- ^ List to set colors via groups. + , spColorMap :: Maybe T.Text + -- ^ Specification of color map; only colorbrewer types supported. + , spSize :: Maybe [Int] + -- ^ List to set point sizes. + , spAlpha :: Maybe [Double] + -- ^ List of alpha values to set file and stroke opacity. + , spXaxis :: Maybe T.Text + -- ^ Label for x-axis. + , spYaxis :: Maybe T.Text + -- ^ Label for y-axis. + , spToolTips :: Maybe Bool + -- ^ Whether or not to display tooltips. + , spZoom :: Maybe Bool + -- ^ Whether or not to allow zooming. + , spBrush :: Maybe Bool + -- ^ Whether or not to support brushing. + } + deriving (Show, Eq) + +instance Default ScatterPlot where + def = ScatterPlot [] [] Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing (Just True) (Just True) (Just True) + +instance ToJSON ScatterPlot where + toJSON (ScatterPlot xs ys vs ls cs gs cm ss as xa ya t z b) = + omitNulls [ "points" .= getPoints xs ys + , "values" .= vs + , "labels" .= ls + , "color" .= cs + , "group" .= gs + , "colormap" .= cm + , "size" .= ss + , "alpha" .= as + , "xaxis" .= xa + , "yaxis" .= ya + , "tooltips" .= t + , "zoom" .= z + , "brush" .= b + ] + +instance ValidatablePlot ScatterPlot where + validatePlot (ScatterPlot xs ys v lbl c grp cm s a xa ya tt z b) = do + (xs', ys') <- validateCoordinates xs ys + c' <- validateColor c + cm' <- validateColorMap cm + s' <- validateSize s + a' <- validateAlpha a + return $ ScatterPlot xs' ys' v lbl c' grp cm' s' a' xa ya tt z b + +-- | Submits a request to the specified lightning-viz server to create +-- a scatter plot. +-- +-- +scatterPlot :: Monad m => ScatterPlot + -- ^ Scatter plot to create. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +scatterPlot scatterPlt = do + url <- ask + viz <- sendPlot "scatter" scatterPlt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Scatter3.hs b/src/Web/Lightning/Plots/Scatter3.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Scatter3.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize (x,y,z) co-ordinates as a 3D scatter plot. +module Web.Lightning.Plots.Scatter3 + ( + Scatter3Plot(..) + , Visualization (..) + , scatter3Plot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Scatter Plot 3D parameters +data Scatter3Plot = + Scatter3Plot { sptX :: [Double] + -- ^ List of x points. + , sptY :: [Double] + -- ^ List of y points. + , sptZ :: [Double] + -- ^ List of z points. + , sptColors :: Maybe [Int] + -- ^ List of rgb values to set colors. + , sptGroups :: Maybe [Int] + -- ^ List to set colors via groups. + , sptSize :: Maybe [Int] + -- ^ List to set point sizes. + , sptAlpha :: Maybe [Double] + -- ^ List of alpha values to set file and stroke opacity. + } + deriving (Show, Eq) + +instance Default Scatter3Plot where + def = Scatter3Plot [] [] [] Nothing Nothing Nothing Nothing + +instance ToJSON Scatter3Plot where + toJSON (Scatter3Plot xs ys zs cs gs ss as) = + omitNulls [ "points" .= getPoints3 xs ys zs + , "color" .= cs + , "group" .= gs + , "size" .= ss + , "alpha" .= as + ] + +instance ValidatablePlot Scatter3Plot where + validatePlot (Scatter3Plot xs ys zs c g s a) = do + (xs', ys', zs') <- validateCoordinates3 xs ys zs + c' <- validateColor c + s' <- validateSize s + a' <- validateAlpha a + return $ Scatter3Plot xs' ys' zs' c' g s' a' + +-- | Submits a request to the specified lightning-viz server to create +-- a 3D scatter plot. +-- +-- +scatter3Plot :: Monad m => Scatter3Plot + -- ^ Scatter plot to create + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +scatter3Plot scatter3Plt = do + url <- ask + viz <- sendPlot "scatter-3" scatter3Plt R.plot + return $ viz { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/ScatterStream.hs b/src/Web/Lightning/Plots/ScatterStream.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/ScatterStream.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize one-dimensional series data as lines. +module Web.Lightning.Plots.ScatterStream + ( + ScatterStreamPlot(..) + , Visualization (..) + , streamingScatterPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.Reader + +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Visualization (Visualization (..)) +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Scatter plot parameters +data ScatterStreamPlot = + ScatterStreamPlot { sspX :: [Double] + -- ^ List of x points. + , sspY :: [Double] + -- ^ List of y points. + , sspValues :: Maybe [Double] + -- ^ Values to set node colors via a linear scale. + , sspLabels :: Maybe [T.Text] + -- ^ List of text labels to set tooltips. + , sspColor :: Maybe [Int] + -- ^ List of rgb values to set colors. + , sspGroup :: Maybe [Int] + -- ^ List to set colors via groups. + , sspColorMap :: Maybe T.Text + -- ^ Specification of color map; only colorbrewer types supported. + , sspSize :: Maybe [Int] + -- ^ List to set point sizes. + , sspXaxis :: Maybe T.Text + -- ^ Label for x-axis. + , sspYaxis :: Maybe T.Text + -- ^ Label for y-axis. + , sspToolTips :: Maybe Bool + -- ^ Whether or not to display tooltips. + , sspZoom :: Maybe Bool + -- ^ Whether or not to allow zooming. + , sspBrush :: Maybe Bool + -- ^ Whether or not to support brushing. + , sspVisualization :: Maybe Visualization + -- ^ The visualization to update. If Nothing, create + } + deriving (Show) + +instance Default ScatterStreamPlot where + def = ScatterStreamPlot [] [] Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing (Just True) (Just True) (Just True) Nothing + + +instance ToJSON ScatterStreamPlot where + toJSON (ScatterStreamPlot xs ys vs ls cs gs cm ss xa ya t z b _) = + omitNulls [ "points" .= getPoints xs ys + , "values" .= vs + , "labels" .= ls + , "color" .= cs + , "group" .= gs + , "colormap" .= cm + , "size" .= ss + , "xaxis" .= xa + , "yaxis" .= ya + , "tooltips" .= t + , "zoom" .= z + , "brush" .= b + ] + +instance ValidatablePlot ScatterStreamPlot where + validatePlot (ScatterStreamPlot xs ys v lbl c grp cm s xa ya tt z b viz) = do + (xs', ys') <- validateCoordinates xs ys + c' <- validateColor c + cm' <- validateColorMap cm + s' <- validateSize s + return $ ScatterStreamPlot xs' ys' v lbl c' grp cm' s' xa ya tt z b viz + +-- | Create a streaming scatter plot of x and y. +-- +-- Plotting once returns a visualization on which 'append' can be called to add new data +-- in a streaming fashion. The opacity of old and new data is automatically set +-- to highlight the most recent data and fade old data away. +-- +-- +streamingScatterPlot :: Monad m => ScatterStreamPlot + -- ^ Scatter plot to create / update. + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +streamingScatterPlot slp = do + url <- ask + viz' <- streamPlot (sspVisualization slp) "scatter-streaming" slp R.plot + return $ viz' { vizBaseUrl = Just url } diff --git a/src/Web/Lightning/Plots/Volume.hs b/src/Web/Lightning/Plots/Volume.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Plots/Volume.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Visualize a collection of images as a three-dimensional volume. +module Web.Lightning.Plots.Volume + ( + VolumePlot(..) + , Visualization (..) + , volumePlot + ) + where + +-------------------------------------------------------------------------------- +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import qualified Web.Lightning.Routes as R +import Web.Lightning.Types.Lightning +import Web.Lightning.Types (Img) +import Web.Lightning.Types.Visualization (Visualization (..)) +-------------------------------------------------------------------------------- + +-- | Volume plot parameters +data VolumePlot = VolumePlot { vpImages :: [Img] + -- ^ A collection of images to display. Can be + -- 2 dimensional (grey scale) or 3 dimensional + -- (RGB) lists. + } + deriving (Show, Eq) + +instance Default VolumePlot where + def = VolumePlot [ [[[]]] ] + +instance ToJSON VolumePlot where + toJSON (VolumePlot imgs) = + object [ "images" .= imgs ] + +instance ValidatablePlot VolumePlot where + validatePlot = return + +-- | Submits a request to the specified lightning-viz server to create +-- a visualization of a collection of images as a three-dimensional volume. +-- +-- +volumePlot :: Monad m => T.Text + -- ^ Base URL for lightning-viz server. + -> VolumePlot + -- ^ Volume plot to create + -> LightningT m Visualization + -- ^ Transformer stack with created visualization. +volumePlot bUrl volumePlt = do + viz <- sendPlot "volume" volumePlt R.plot + return $ viz { vizBaseUrl = Just bUrl } diff --git a/src/Web/Lightning/Render.hs b/src/Web/Lightning/Render.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Render.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Contains functions needed for rendering plots in IHaskell. +module Web.Lightning.Render + ( + -- * IHaskell Rendering + renderPlot + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) + +import Network.API.Builder.Error +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +import qualified Text.Blaze.Html as BZ + +import Web.Lightning.Types.Visualization (Visualization (..), + getPublicLink) +-------------------------------------------------------------------------------- + +-- | For use in IHaskell - Renders the visualization in an IHaskell notebook. +renderPlot :: Either (APIError a) Visualization + -- ^ The visualization to render. + -> IO BZ.Markup + -- ^ The HTML representation of the visualization. +renderPlot (Left _) = return $ BZ.string "No visualization." +renderPlot (Right viz) = do + manager <- liftIO $ newManager tlsManagerSettings + req <- parseRequest $ T.unpack $ getPublicLink viz + vizHtml <- httpLbs req manager + + return $ BZ.preEscapedToMarkup $ + decodeUtf8 $ BS.toStrict $ responseBody vizHtml diff --git a/src/Web/Lightning/Routes.hs b/src/Web/Lightning/Routes.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Routes.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Routes +Description : Defines route mappings to lightning-viz API endpoints. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Defines the Route mappings to the lightning-viz API. +-} + +module Web.Lightning.Routes + ( -- * API Endpoints + plot + , stream + , publicLink + ) + where + +-------------------------------------------------------------------------------- +import Network.API.Builder hiding (runRoute) + +import Web.Lightning.Types.Visualization (Visualization (..)) +-------------------------------------------------------------------------------- + +-- | The main route that corresponds to the /visualizations endpoint. Using +-- this route, one can create and update plots. +plot :: Route + -- ^ Returns a new route corresponding to /sessionId/visualizations. +plot = Route ["visualizations"] + [] + "POST" + +-- | This route is used in conjunction with streaming plot functions. +stream :: Visualization + -- ^ Visualization to append + -> Route + -- ^ Returns the URL to update the visualization. +stream (Visualization i _ _) = + Route ["visualizations", i, "data"] + [] + "POST" + +-- | Corresponds to the public URL of a visualization. +publicLink :: Visualization + -- ^ The visualization to create the public link for. + -> Route + -- ^ Route representing public link for visualization. +publicLink (Visualization i _ _) = + Route ["visualizations", i, "public"] + [] + "GET" diff --git a/src/Web/Lightning/Session.hs b/src/Web/Lightning/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Session.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Session +Description : Session management. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Defines interactions with the session endpoint. +-} + +module Web.Lightning.Session + ( + -- * Session Functions + createSession + , module Web.Lightning.Types.Session + ) where + +-------------------------------------------------------------------------------- +import Data.Maybe +import qualified Data.Text as T + +import Network.API.Builder hiding (runRoute) + +import Web.Lightning.Types.Lightning +import Web.Lightning.Types.Session +-------------------------------------------------------------------------------- + +-- | Session endpoint. +createSessionRoute :: Maybe T.Text + -- ^ An optional name for the session + -> Route + -- ^ The lightning-viz session endpoint +createSessionRoute n = Route ["sessions"] + ["name" =. fromMaybe "" n] + "POST" + +-- | Creates a new session with an optional name. +createSession :: Monad m => Maybe T.Text + -- ^ An optional session name + -> LightningT m Session + -- ^ Returns the LightningT transformer stack +createSession n = receiveRoute $ createSessionRoute n diff --git a/src/Web/Lightning/Types.hs b/src/Web/Lightning/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Types.hs @@ -0,0 +1,37 @@ +{-| +Module : Web.Lightning.Types +Description : Re-exports main types. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Re-exports all the main types one is likely to need. +-} + +module Web.Lightning.Types + ( + -- * Lightning Types + LightningError(..) + , Session(..) + , Visualization(..) + , Pixel + , Img + ) + where + +-------------------------------------------------------------------------------- +import Data.Word + +import Web.Lightning.Types.Error (LightningError (..)) +import Web.Lightning.Types.Session (Session (..)) +import Web.Lightning.Types.Visualization (Visualization (..)) +-------------------------------------------------------------------------------- + +-- | Can represent an RGBA [red, green, blue, alpha], +-- RGB [red, green, blue], and GreyScale [intensity] pixel. +type Pixel = [Word8] + +-- | Represents an image as a matrix of pixels. +type Img = [[Pixel]] diff --git a/src/Web/Lightning/Types/Error.hs b/src/Web/Lightning/Types/Error.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Types/Error.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Types.Error +Description : Lightning error type +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX +-} + +module Web.Lightning.Types.Error + ( + -- Error Types + LightningError(..) + ) where + +-------------------------------------------------------------------------------- +import Data.Aeson +import qualified Data.Text as T + +import Network.API.Builder.Receive +-------------------------------------------------------------------------------- + +-- | Represents the different errors that may be raised in the lightning-viz +-- wrapper. +data LightningError = LightningError Object + -- ^ Represents a JSON error returned by lightning-viz. + | FailError T.Text + -- ^ Represents a generic exception error. + | ValidationError T.Text + -- ^ Represents a validation error in a request record. + deriving (Show, Eq) + +instance FromJSON LightningError where + parseJSON (Object o) = return $ LightningError o + parseJSON _ = mempty + +instance ErrorReceivable LightningError where + receiveError = useErrorFromJSON diff --git a/src/Web/Lightning/Types/Lightning.hs b/src/Web/Lightning/Types/Lightning.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Types/Lightning.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Types.Lightning +Description : Main Lightning Types +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX +-} + +module Web.Lightning.Types.Lightning + ( + -- * Lightning Types + Lightning + , LightningF(..) + , LightningT(..) + , ValidatablePlot(..) + -- * Lightning Actions + , runRoute + , sendPlot + , streamPlot + , sendJSON + , receiveRoute + , withBaseURL + , failWith + , liftLightningF + ) + where + +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Free + +import Data.Aeson +import qualified Data.Text as T + +import Network.API.Builder hiding (runRoute) + +import Web.Lightning.Routes (stream) +import Web.Lightning.Types.Error +import Web.Lightning.Types.Visualization +import Web.Lightning.Utilities +-------------------------------------------------------------------------------- + +-- | Allows plot fields to be validated. +class ValidatablePlot a where + validatePlot :: a -> Either LightningError a + +-- | Represents an IO Lightning transformer action. +type Lightning a = LightningT IO a + +-- | Represents a URL. +type BaseUrl = T.Text + +-- | Defines the available actions +data LightningF m a where + FailWith :: APIError LightningError -> LightningF m a + ReceiveRoute :: Receivable b => Route -> (b -> a) -> LightningF m a + RunRoute :: FromJSON b => Route -> (b -> a) -> LightningF m a + SendJSON :: (Receivable b) => Value -> Route -> (b -> a) -> LightningF m a + WithBaseURL :: T.Text -> LightningT m b -> (b -> a) -> LightningF m a + +instance Functor (LightningF m) where + fmap _ (FailWith x) = FailWith x + fmap f (ReceiveRoute r x) = ReceiveRoute r (fmap f x) + fmap f (RunRoute r x) = RunRoute r (fmap f x) + fmap f (SendJSON js r x) = SendJSON js r (fmap f x) + fmap f (WithBaseURL u a x) = WithBaseURL u a (fmap f x) + +-- | Defines free monad transformer +newtype LightningT m a = LightningT (ReaderT BaseUrl (FreeT (LightningF m) m) a) + deriving (Functor, Applicative, Monad, MonadReader T.Text) + +instance MonadIO m => MonadIO (LightningT m) where + liftIO = LightningT . liftIO + +instance MonadTrans LightningT where + lift = LightningT . lift . lift + +-- | Lifts a 'LightningF' free monad into the ReaderT context. +liftLightningF :: (Monad m) => FreeT (LightningF m) m a + -> ReaderT T.Text (FreeT (LightningF m) m) a +liftLightningF = lift + +-- | Runs a route action within the free monadic transformer context. +runRoute :: (FromJSON a, Monad m) => Route + -- ^ Route to run + -> LightningT m a + -- ^ Monad transformer stack with result. +runRoute r = LightningT $ liftF $ RunRoute r id + +-- | Sends a request to the lightning-viz server to create a visualization. +sendPlot :: (ToJSON p, ValidatablePlot p, Receivable a, Monad m) => T.Text + -- ^ The plot type + -> p + -- ^ The plot creation request + -> Route + -- ^ The plot route. + -> LightningT m a + -- ^ Monad transformer stack with result. +sendPlot t p r = + case validatePlot p of + Left err -> failWith (APIError err) + Right p' -> sendJSON (createPayLoad t $ toJSON p') r + +-- | Sends a request to either create a brand new streaming plot or +-- to append data to an existing streaming plot. +streamPlot :: (ToJSON p, + ValidatablePlot p, + Receivable a, + Monad m) => Maybe Visualization + -- ^ Visualization to update. If nothing, create + -- a new plot. + -> T.Text + -- ^ Plot type + -> p + -- ^ Plot payload + -> Route + -- ^ Route to send plot to. + -> LightningT m a + -- ^ Monad transformer stack with result. +streamPlot viz t p r = + case validatePlot p of + Left err -> failWith (APIError err) + Right _ -> streamOrCreate viz + where + streamOrCreate (Just viz') = sendJSON (createDataPayLoad $ toJSON p) (stream viz') + streamOrCreate Nothing = sendJSON (createPayLoad t $ toJSON p) r + +-- | Sends a request containing JSON to the specified route. +sendJSON :: (Receivable a, Monad m) => Value + -- ^ The JSON payload + -> Route + -- ^ Route to send request to + -> LightningT m a + -- ^ Monad transformer stack with result. +sendJSON j r = LightningT $ liftF $ SendJSON j r id + +-- | Send and receives a GET request to the specified route. +receiveRoute :: (Receivable a, Monad m) => Route + -- ^ The route to retrieve data from. + -> LightningT m a + -- ^ Monad transformer stack with result. +receiveRoute r = LightningT $ liftF $ ReceiveRoute r id + +-- | Replaces the base URL in the stack and run the supplied action afterwards. +withBaseURL :: Monad m => T.Text + -- ^ The new base URL. + -> LightningT m a + -- ^ Next action to run. + -> LightningT m a + -- ^ Monad transformer stack with result. +withBaseURL u f = LightningT $ liftF $ WithBaseURL u f id + +-- | Returns an error message. +failWith :: Monad m => APIError LightningError + -- ^ The error message to return. + -> LightningT m a + -- ^ Monad transformer stack with error. +failWith = LightningT . liftF . FailWith diff --git a/src/Web/Lightning/Types/Session.hs b/src/Web/Lightning/Types/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Types/Session.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Types.Session +Description : Session management types. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Defines the types needed for interaction with the session endpoint. +-} + +module Web.Lightning.Types.Session + ( + -- * Session Types + Session(..) + ) + where + +-------------------------------------------------------------------------------- +import Data.Aeson +import Data.Default.Class +import qualified Data.Text as T + +import Network.API.Builder hiding (runRoute) +-------------------------------------------------------------------------------- + +-- | Represents a lightning-viz session. A session ID is required to create +-- a plot. +data Session = + Session { snId :: T.Text + -- ^ The unique session ID + , snName :: Maybe T.Text + -- ^ The optional session name + , snUpdated :: Maybe T.Text + -- ^ The timestamp of when the session was last updated + , snCreated :: Maybe T.Text + -- ^ Creation timestamp + } + deriving (Show, Read, Eq) + +instance FromJSON Session where + parseJSON (Object v) = + Session <$> + v .: "id" <*> + v .: "name" <*> + v .: "updatedAt" <*> + v .: "createdAt" + parseJSON _ = mempty + +instance Receivable Session where + receive = useFromJSON + +instance Default Session where + def = Session "" Nothing Nothing Nothing diff --git a/src/Web/Lightning/Types/Visualization.hs b/src/Web/Lightning/Types/Visualization.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Types/Visualization.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Types.Visualization +Description : Visualization type +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Describes the primary visualization return type along +with some helper functions. +-} + +module Web.Lightning.Types.Visualization + ( + -- * Visualization Types + Visualization(..) + -- * Visualization Helper Functions + , getEmbedLink + , getIFrameLink + , getPymLink + , getPublicLink + ) + where + +-------------------------------------------------------------------------------- +import Data.Aeson +import qualified Data.Text as T + +import Network.API.Builder hiding (runRoute) + +import Web.Lightning.Utilities (defaultBaseURL) +-------------------------------------------------------------------------------- + +-- | Encapsulates the basic information about a created +-- visualization. +data Visualization = + Visualization { vizId :: T.Text + -- ^ The unique identifier for a visualization + , vizSessionID :: T.Text + -- ^ The session ID the visualization was created in + , vizBaseUrl :: Maybe T.Text + -- ^ Base URL gets filled in later + } deriving (Show) + +instance FromJSON Visualization where + parseJSON (Object o) = + Visualization <$> o .: "id" + <*> o .: "SessionId" + <*> o .:? "url" + parseJSON _ = mempty + +instance Receivable Visualization where + receive = useFromJSON + +-- | Appends a '/' to a URL if it is not there already. +formatURL :: T.Text + -- ^ Base URL + -> T.Text + -- ^ Returns the formatted URL +formatURL url = + case T.last url of + '/' -> url + _ -> T.concat [url, "/"] + +-- | Returns the permanent link for a visualization. +getPermaLinkURL :: Visualization + -- ^ The visualization to get permalink for + -> T.Text + -- ^ Returns the permalink for visualization. +getPermaLinkURL (Visualization i _ (Just bUrl)) = + T.concat [formatURL bUrl, "visualizations/", i] +getPermaLinkURL (Visualization i _ Nothing) = + T.concat [formatURL defaultBaseURL, "visualizations/", i] + +-- | Returns a partial URL based on the link type parameter. +getLinkType :: Visualization + -- ^ Visualization to create link for + -> T.Text + -- ^ The link type + -> T.Text + -- ^ The partially formatted URL +getLinkType viz link = formatURL $ T.concat [permaLink, link] + where permaLink = getPermaLinkURL viz + +-- | Returns the embedded link URL for a visualization. +getEmbedLink :: Visualization + -- ^ Visualization to create embedded link + -> T.Text + -- ^ Returns the embedded link for visualization +getEmbedLink viz = getLinkType viz "/embed/" + +-- | Returns the iFrame link URL for a visualization +getIFrameLink :: Visualization + -- ^ Visualization to create iFrame link for + -> T.Text + -- ^ Returns the iFrame link for visualization +getIFrameLink viz = getLinkType viz "/iframe/" + +-- | Returns the PYM link for visualization. +getPymLink :: Visualization + -- ^ Visualization to create PYM link for + -> T.Text + -- ^ Returns the PYM link for visualization +getPymLink viz = getLinkType viz "/pym/" + +-- | Returns the public link for a visualization. +getPublicLink :: Visualization + -- ^ Visualization to create public link for. + -> T.Text + -- ^ Returns the public link for visualization. +getPublicLink viz = getLinkType viz "/public/" diff --git a/src/Web/Lightning/Utilities.hs b/src/Web/Lightning/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Web/Lightning/Utilities.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Web.Lightning.Utilities +Description : Commonly used utility functions. +Copyright : (c) Connor Moreside, 2016 +License : BSD-3 +Maintainer : connor@moresi.de +Stability : experimental +Portability : POSIX + +Contains commonly used utility functions used throughout the library. +-} + +module Web.Lightning.Utilities + ( + -- * Utility Functions + omitNulls + , createPayLoad + , createDataPayLoad + , addSessionId + , getLinks + , getNodes + , getPoints + , getPoints3 + -- * Validation Functions + , validateBin + , validateColor + , validateColorMap + , validateSize + , validateAlpha + , validateThickness + , validateIndex + , validateCoordinates + , validateCoordinates3 + , validateRegion + , validateConn + , defaultBaseURL + ) + where + +-------------------------------------------------------------------------------- +import Data.Aeson +import qualified Data.Text as T + +import Web.Lightning.Types.Error +-------------------------------------------------------------------------------- + +-- | Used in conjunction with ToJSON. It will stop any field that is +-- Nothing (null) in a record from being encoded in JSON. +omitNulls :: [(T.Text, Value)] + -- ^ The plot object to be serialized into JSON Value + -> Value + -- ^ The plot object with Nothing (null) fields removed. +omitNulls = object . filter notNull where + notNull (_, Null) = False + notNull _ = True + +-- | Converts the plot creation request record into the proper +-- JSON object that the lightning-viz server expects. +createPayLoad :: T.Text + -- ^ The name of the type of plot to create + -> Value + -- ^ The plot creation request record in JSON Value format + -> Value + -- ^ The properly encoded payload object +createPayLoad t p = object [("type", toJSON t), ("data", p)] + +-- | Creates a payload for streaming plots. +createDataPayLoad :: Value + -- ^ Data to update. + -> Value + -- ^ The properly encoded payload object. +createDataPayLoad p = object [("data", p)] + +-- | Appends the session route and session id to current URL. +addSessionId :: T.Text + -- ^ The current URL + -> T.Text + -- ^ The session ID to add to current URL + -> T.Text + -- ^ Returns the URL with the session ID +addSessionId url sId = url `T.append` "/sessions/" `T.append` sId + +-- | Retrieves all the links for each of the nodes in the adjacency +-- matrix. +getLinks :: [[Double]] + -- ^ The adjacency matrix + -> [[Double]] + -- ^ All the links for each of the nodes +getLinks conn + | length conn == length (head conn) = s1 (zipWithIndex conn) + | otherwise = s4 conn + where s1 = concatMap (\(row, i) -> s3 i (s2 (zipWithIndex row))) + s2 = filter (\(x, _) -> x /= 0) + s3 i = map (\(x, j) -> [i, j, x] :: [Double]) + s4 xs = case length xs of + 2 -> xs + 3 -> map (\l -> [head l, l !! 1, 1.0]) xs + _ -> [[]] + +zipWithIndex :: (Enum b, Num b) => [a] -> [(a, b)] +zipWithIndex [] = [] +zipWithIndex xs = zipWith (\i el -> (i, el)) xs [0..] + +-- | Retrieves all of the nodes from an adjacency matrix. +getNodes :: [[Double]] + -- ^ The adjacency matrix + -> [Int] + -- ^ A list of all of the nodes in matrix +getNodes conn + | length conn == length (head conn) = [0..length conn - 1] + | otherwise = [0..n - 1] + where n = floor $ maximum $ map maximum conn + + +-- | Zips up x and y points into array pairs. +getPoints :: [Double] + -- ^ X points + -> [Double] + -- ^ Y points + -> [[Double]] + -- ^ Returns [ [x, y] ] pairs +getPoints xs ys = map (\(x, y) -> [x, y]) $ zip xs ys + +-- | Zips up x, y, and z points into array triples. +getPoints3 :: [Double] + -- ^ X points + -> [Double] + -- ^ Y points + -> [Double] + -- ^ Z points + -> [[Double]] + -- ^ Returns [ [x, y, z] ] triplets +getPoints3 xs ys zs = map (\(x, y, z) -> [x, y, z]) $ zip3 xs ys zs + +-- | Validates the bins of a histogram +validateBin :: Maybe [Double] + -> Either LightningError (Maybe [Double]) +validateBin = return + +-- | Verify that the color specs are either in the form of +-- [r, g, b] or a list of [[r,g,b],[r,g,b],...] +validateColor :: Maybe [Int] + -> Either LightningError (Maybe [Int]) +validateColor (Just colors) + | length colors == 3 = Right (Just colors) + | otherwise = Left $ ValidationError "Color must have three values." +validateColor Nothing = Right Nothing + +-- | Verifiy that the color map specified is on of the colorbrewer maps. +-- +-- Here are the available colorbrewer values: +-- "BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", +-- "RdYlGn", "Spectral", "Blues", "BuGn", "BuPu", "GnBu", +-- "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", +-- "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", +-- "YlOrBr", "YlOrRd", "Accent", "Dark2", "Paired", "Pastel1", +-- "Pastel2", "Set1", "Set2", "Set3", or "Lightning" +validateColorMap :: Maybe T.Text + -> Either LightningError (Maybe T.Text) +validateColorMap cm@(Just cmv) = + if cmv `elem` colorMaps + then Right cm + else Left $ ValidationError "Invalid color map specified." + where colorMaps = ["BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", + "RdYlGn", "Spectral", "Blues", "BuGn", "BuPu", "GnBu", + "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", + "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", + "YlOrBr", "YlOrRd", "Accent", "Dark2", "Paired", "Pastel1", + "Pastel2", "Set1", "Set2", "Set3", "Lightning"] +validateColorMap Nothing = Right Nothing + +-- | Verify that all size values are greater than zero. +validateSize :: Maybe [Int] + -> Either LightningError (Maybe [Int]) +validateSize size = validateGreaterThan0 size msg + where msg = "Sizes cannot be 0 or negative." + +-- | Verify all alpha values are greater than 0 +validateAlpha :: Maybe [Double] + -> Either LightningError (Maybe [Double]) +validateAlpha alpha = validateGreaterThan0 alpha msg + where msg = "Alpha cannot be 0 or negative." + +-- | Verify all thickness values are greater than 0. +validateThickness :: Maybe [Int] + -> Either LightningError (Maybe [Int]) +validateThickness thickness = validateGreaterThan0 thickness msg + where msg = "Thickness cannot be 0 or negative." + +-- | Verify that there is at least one element in list. +validateIndex :: Maybe [Int] + -> Either LightningError (Maybe [Int]) +validateIndex index@(Just idx) + | not (null idx) = Right index + | otherwise = Left $ ValidationError "Index must be non-singleton." +validateIndex Nothing = Right Nothing + +-- | Verify that the length of vector x is equal to length of vector y. +validateCoordinates :: [Double] + -- ^ x vector + -> [Double] + -- ^ y vector + -> Either LightningError ([Double], [Double]) +validateCoordinates xs ys = + if length xs == length ys + then Right (xs, ys) + else Left $ ValidationError "x and y vectors must be the same length." + +-- | Verify that the lenths of the x, y, and z vectors are the same length. +validateCoordinates3 :: [Double] + -- ^ x vector + -> [Double] + -- ^ y vector + -> [Double] + -- ^ z vector + -> Either LightningError ([Double],[Double],[Double]) +validateCoordinates3 xs ys zs = + if (length xs == length ys) && (length ys == length zs) + then Right (xs, ys, zs) + else Left $ ValidationError "x, y, and z vectors must be the same length." + +-- | Verify that the lengths of the region names are either 2 letters or 3 +-- letters. +-- +-- 2 letter region names must correspond to US states and 3 letter +-- region names must correspond to countries of the world. +validateRegion :: [T.Text] + -> Either LightningError [T.Text] +validateRegion regions = + if checkTwo || checkThree + then Right regions + else Left $ ValidationError msg + where + msg = "All region names must be all 2 letters or all 3 letters." + checkTwo = all (\x -> T.length x == 2) regions + checkThree = all (\x -> T.length x == 3) regions + +-- | Verify that the multi-dimensional list adheres to expected dimensions. +validateConn :: [[Double]] + -> Either LightningError [[Double]] +validateConn conn + | length conn == length (head conn) = Right conn + | length (head conn) == 2 = Right conn + | length (head conn) == 3 = Right conn + | otherwise = Left $ ValidationError msg + where + msg = "Too many entries per link, must be 2 or 3." + +-- | Ensure all values are greater than 0. +validateGreaterThan0 :: (Ord a, Num a) => Maybe [a] + -> T.Text + -> Either LightningError (Maybe [a]) +validateGreaterThan0 vals@(Just vs) msg = + if any (<= 0) vs + then Left $ ValidationError msg + else Right vals +validateGreaterThan0 Nothing _ = Right Nothing + +-- | Defines the default URL for the lightning-viz server. +defaultBaseURL :: T.Text +defaultBaseURL = "http://localhost:3000" diff --git a/test-integration/ConfigLightning.hs b/test-integration/ConfigLightning.hs new file mode 100644 --- /dev/null +++ b/test-integration/ConfigLightning.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module ConfigLightning where + +import qualified Data.Text as T + +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.API.Builder + +import System.Environment +import System.Exit + +import Web.Lightning.Session +import Web.Lightning + +isRight :: Either a b -> Bool +isRight = const False `either` const True + +isLeft :: Either a b -> Bool +isLeft = const True `either` const False + +newtype RunLightning = RunLightning + { run :: forall a. Lightning a -> IO (Either (APIError LightningError) a) } + +configLightning :: IO RunLightning +configLightning = do + url <- getEnv "LIGHTNING_VIZ_URL" + manager <- newManager tlsManagerSettings + session <- interpretIO (LightningState (T.pack url) manager Nothing id) $ createSession (Just "Integration Tests") + case session of + Left _ -> exitFailure + Right s -> + return $ RunLightning $ runLightningWith (LightningOptions (Just manager) (T.pack url) Anonymous (Just s)) diff --git a/test-integration/Spec.hs b/test-integration/Spec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-integration/Web/Lightning/PlotSpec.hs b/test-integration/Web/Lightning/PlotSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Web/Lightning/PlotSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.Lightning.PlotSpec where + +import ConfigLightning + +import Control.Monad.IO.Class + +import Test.Hspec + +import Data.Maybe +import qualified Data.Text as T + +import System.Environment + +import Web.Lightning +import Web.Lightning.Plots +import Web.Lightning.Session + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + lightning <- runIO configLightning + urlStr <- runIO $ getEnv "LIGHTNING_VIZ_URL" + + let url = T.pack urlStr + + describe "Lightning Integration Tests" $ do + it "create Adjacency plot." $ do + res <- run lightning $ adjacencyPlot def { apConn = [[1,2,3],[4,5,6],[7,8,9]] } + res `shouldSatisfy` isRight + it "create Circle plot." $ do + res <- run lightning $ circlePlot def { cpConn = [[1,2,3],[4,5,6],[7,8,9]] } + res `shouldSatisfy` isRight + it "create Force plot." $ do + res <- run lightning $ forcePlot def { fpConn = [[1,2,3],[4,5,6],[7,8,9]] } + res `shouldSatisfy` isRight + it "create Graph plot." $ do + res <- run lightning $ graphPlot def { gpX = [1,2,3], gpY = [1,2,3], gpConn = [[1,2,3],[4,5,6],[7,8,9]] } + res `shouldSatisfy` isRight + it "create GraphBundled plot." $ do + res <- run lightning $ graphPlot def { gpX = [1,2,3], gpY = [1,2,3], gpConn = [[1,2,3],[4,5,6],[7,8,9]] } + res `shouldSatisfy` isRight + it "create Histogram plot." $ do + res <- run lightning $ histogramPlot def { hpValues = [1,2,2,3,3,3,4,4,5] } + res `shouldSatisfy` isRight + it "create Line plot." $ do + res <- run lightning $ linePlot def { lpSeries = [[1,2,3]] } + res `shouldSatisfy` isRight + it "create Map plot." $ do + res <- run lightning $ mapPlot def { mppRegions = ["CAN","USA","MEX"], mppWeights = [13.0,10.0,4.0] } + res `shouldSatisfy` isRight + it "create Matrix plot." $ do + res <- run lightning $ matrixPlot def { mpMatrix = [[1,1,0],[2,0,0],[3,0,0]] } + res `shouldSatisfy` isRight + it "create Scatter plot." $ do + res <- run lightning $ scatterPlot def { spX = [1,2,3], spY = [1,1,1] } + res `shouldSatisfy` isRight + it "create 3D Scatter plot." $ do + res <- run lightning $ scatter3Plot def { sptX = [1,2,3], sptY = [1,1,1], sptZ = [0,0,0] } + res `shouldSatisfy` isRight + it "create Streaming line plot." $ do + res <- run lightning $ streamingLinePlot def { lspSeries = [[1,2,3]] } + res `shouldSatisfy` isRight + it "create Streaming scatter plot." $ do + res <- run lightning $ streamingScatterPlot def { sspX = [1,2,3], sspY = [1,2,3] } + res `shouldSatisfy` isRight diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Web/Lightning/Types/PlotsSpec.hs b/test/Web/Lightning/Types/PlotsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Lightning/Types/PlotsSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.Lightning.Types.PlotsSpec where + +import Test.Hspec + +import Data.Aeson +import Data.Maybe + +import Web.Lightning.Plots +import Web.Lightning.Types.Lightning (validatePlot) + +isRight :: Either a b -> Bool +isRight = const False `either` const True + +isLeft :: Either a b -> Bool +isLeft = const True `either` const False + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Lightning Plot Serialization" $ do + it "encodes default LinePlot property names" $ do + let testInput = def { lpSeries = [[1,2,3]] } :: LinePlot + in encode testInput `shouldBe` "{\"series\":[[1,2,3]],\"zoom\":true}" + it "encodes default HistogramPlot property names" $ do + let testInput = def { hpValues = [1,1,2,2,2,3,3,3], hpZoom = Just False } :: HistogramPlot + in encode testInput `shouldBe` "{\"values\":[1,1,2,2,2,3,3,3],\"zoom\":false}" + it "encodes default ScatterPlot property names" $ do + let testInput = def { spX = [1,2,3], spY = [4,5,6] } :: ScatterPlot + in encode testInput `shouldBe` "{\"points\":[[1,4],[2,5],[3,6]],\"tooltips\":true,\"zoom\":true,\"brush\":true}" + it "encodes default MatrixPlot property names" $ do + let testInput = def { mpMatrix = [[1,2,3],[4,5,6],[7,8,9]] } :: MatrixPlot + in encode testInput `shouldBe` "{\"matrix\":[[1,2,3],[4,5,6],[7,8,9]],\"numbers\":false}" + it "encodes default Scatter3Plot property names" $ do + let testInput = def { sptX = [1,2,3], sptY = [4,5,6], sptZ = [7,8,9] } :: Scatter3Plot + in encode testInput `shouldBe` "{\"points\":[[1,4,7],[2,5,8],[3,6,9]]}" + it "encodes default MapPlot property names" $ do + let testInput = def { mppRegions = ["CAN", "USA"], mppWeights = [0.8, 1.0] } :: MapPlot + in encode testInput `shouldBe` "{\"values\":[0.8,1],\"regions\":[\"CAN\",\"USA\"]}" + it "encodes default AdjacencyPlot property names" $ do + let testInput = def { apConn = [[1,2],[3,4]] } :: AdjacencyPlot + in encode testInput `shouldBe` "{\"symmetric\":true,\"srt\":\"group\",\"numbers\":false,\"links\":[[0,0,1],[0,1,2],[1,0,3],[1,1,4]],\"nodes\":[0,1]}" + it "encodes default CirclePlot property names" $ do + let testInput = def { cpConn = [[1,2],[3,4]], cpGroup = Just [1, 1] } :: CirclePlot + in encode testInput `shouldBe` "{\"group\":[1,1],\"links\":[[0,0,1],[0,1,2],[1,0,3],[1,1,4]],\"nodes\":[0,1]}" + it "encodes default ForcePlot property names" $ do + let testInput = def { fpConn = [[1,2,3],[4,5,6],[7,8,9]] } :: ForcePlot + in encode testInput `shouldBe` "{\"tooltips\":true,\"zoom\":true,\"links\":[[0,0,1],[0,1,2],[0,2,3],[1,0,4],[1,1,5],[1,2,6],[2,0,7],[2,1,8],[2,2,9]],\"nodes\":[0,1,2],\"brush\":true}" + it "encodes default GraphPlot property names" $ do + let testInput = def { gpX = [1,2,3], gpY = [4,5,6], gpConn = [[1,2,3],[4,5,6],[7,8,9]] } :: GraphPlot + in encode testInput `shouldBe` "{\"tooltips\":true,\"zoom\":true,\"links\":[[0,0,1],[0,1,2],[0,2,3],[1,0,4],[1,1,5],[1,2,6],[2,0,7],[2,1,8],[2,2,9]],\"nodes\":[[1,4],[2,5],[3,6]],\"brush\":true}" + + describe "Lighting Plot Validation" $ do + it "should be IsRight for valid AdjacencyPlot." $ do + let testInput = validatePlot $ def { apConn = [[1,2,3],[4,5,6],[7,8,9]] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid AdjacencyPlot." $ do + let testInput = validatePlot $ def { apConn = [[], [1,2,3,4]] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid CirclePlot." $ do + let testInput = validatePlot $ def { apConn = [[1,2],[3,4]] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid CirclePlot." $ do + let testInput = validatePlot $ def { cpConn = [[1,2],[3,4]], cpColor = Just [1,2] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid ForcePlot." $ do + let testInput = validatePlot $ def { fpConn = [[1,2,3],[1,2,3],[1,2,3]], fpBrush = Just False } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid ForcePlot." $ do + let testInput = validatePlot $ def { fpConn = [[], [1.0]] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid GraphPlot." $ do + let testInput = validatePlot $ def { gpX = [1], gpY = [1], gpConn = [[1,2,3]] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid GraphPlot." $ do + let testInput = validatePlot $ def { gpX = [1], gpY = [1,2,3], gpConn = [[1,2,3]] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for HistogramPlot." $ do + let testInput = validatePlot $ def { hpValues = [1,2,1,1,1,4], hpBins = Just [1,2,3] } + in testInput `shouldSatisfy` isRight + it "should be IsRight for valid LinePlot." $ do + let testInput = validatePlot $ def { lpSeries = [[1,2,3]], lpColor = Just [244,0,100] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid LinePlot." $ do + let testInput = validatePlot $ def { lpSeries = [[1,2,3,4]], lpColor = Just [0] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid MapPlot." $ do + let testInput = validatePlot $ def { mppRegions = ["USA","CAN"], mppWeights = [0.2,1.3] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid MapPlot." $ do + let testInput = validatePlot $ def { mppRegions = ["USA","CAN", "AL"], mppWeights = [0.2,1.3] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid MatrixPlot." $ do + let testInput = validatePlot $ def { mpMatrix = [[1,2,3],[4,5,6]] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid MatrixPlot." $ do + let testInput = validatePlot $ def { mpMatrix = [[1,2,3],[4,5,6],[7,8,9]], mpColorMap = Just "NotAColorMap" } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid ScatterPlot." $ do + let testInput = validatePlot $ def { spX = [1,2,3], spY = [1,2,3] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid ScatterPlot." $ do + let testInput = validatePlot $ def { spX = [1,2,3], spY = [0,0,0], spAlpha = Just [-1,0,1] } + in testInput `shouldSatisfy` isLeft + it "should be IsRight for valid ScatterPlot3." $ do + let testInput = validatePlot $ def { sptX = [1,2,3], sptY = [1,2,3], sptZ = [0,0,0] } + in testInput `shouldSatisfy` isRight + it "should be IsLeft for invalid ScatterPlot3." $ do + let testInput = validatePlot $ def { sptX = [1,2,3], sptY = [0,0,0], sptZ = [1,2,3,4] } + in testInput `shouldSatisfy` isLeft diff --git a/test/Web/Lightning/UtilitySpec.hs b/test/Web/Lightning/UtilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Lightning/UtilitySpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.Lightning.UtilitySpec where + +import Test.Hspec + +import Data.Aeson + +import Web.Lightning.Plots +import Web.Lightning.Utilities + +isRight :: Either a b -> Bool +isRight = const False `either` const True + +isLeft :: Either a b -> Bool +isLeft = const True `either` const False + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Lightning Utilities" $ do + it "createPayLoad should wrap plot and type in JSON object" $ do + let plotValue = toJSON $ def { lpSeries = [[1,2,3]]} + payload = createPayLoad "line" plotValue + in encode payload `shouldBe` "{\"data\":{\"series\":[[1,2,3]],\"zoom\":true},\"type\":\"line\"}" + it "addSessionId appends session ID to URL" $ do + addSessionId defaultBaseURL "1b95a317-088e-4deb-a415-76962356742b" `shouldBe` "http://localhost:3000/sessions/1b95a317-088e-4deb-a415-76962356742b" + it "getPoints zips x and y points into x-y co-ordinates" $ do + getPoints [1,2,3] [4,5,6] `shouldBe` [[1.0,4.0],[2.0,5.0],[3.0,6.0]] + it "getPoints3 zips x, y, and z points into xyz co-ordinates" $ do + getPoints3 [1,2,3] [4,5,6] [7,8,9] `shouldBe` [[1.0,4.0,7.0],[2.0,5.0,8.0],[3.0,6.0,9.0]] + it "getNodes # of nodes from adjacency matrix" $ do + getNodes [[1,2,3],[4,5,6],[7,8,9]] `shouldBe` [0,1,2] + it "getLinks converts adjacency matrix to [source, target, value] form." $ do + getLinks [[1,2],[3,4]] `shouldBe` [[0.0,0.0,1.0],[0.0,1.0,2.0],[1.0,0.0,3.0],[1.0,1.0,4.0]] + + describe "Plot Validation Utilities" $ do + it "validateBin should be idempotent with Just value." $ do + let test = validateBin $ Just [1.0,2.0,3.0] + in test `shouldSatisfy` isRight + it "validateBin should be idempotent with Nothing value." $ do + let test = validateBin Nothing + in test `shouldSatisfy` isRight + it "validateColor should be IsRight with [r,g,b] value." $ do + let test = validateColor $ Just [255,0,0] + in test `shouldSatisfy` isRight + it "validateColor should be IsLeft with [a,b,c,d] value." $ do + let test = validateColor $ Just [255,0,0,0] + in test `shouldSatisfy` isLeft + it "validateColorMap should be IsRight with valid color map." $ do + let test = validateColorMap $ Just "BrBG" + in test `shouldSatisfy` isRight + it "validateColorMap should be IsLeft with invalid color map." $ do + let test = validateColorMap $ Just "NotValidColorMap" + in test `shouldSatisfy` isLeft + it "validateSize should be IsRight with positive values." $ do + let test = validateSize $ Just [1,2,3] + in test `shouldSatisfy` isRight + it "validateSize should be IsLeft with 0 or below values." $ do + let test = validateSize $ Just [0,0,-1] + in test `shouldSatisfy` isLeft + it "validateAlpha should be IsRight with positive values." $ do + let test = validateAlpha $ Just [1,2,3] + in test `shouldSatisfy` isRight + it "validateAlpha should be IsLeft with 0 or below values." $ do + let test = validateAlpha $ Just [-10,3,0] + in test `shouldSatisfy` isLeft + it "validateThickness should be IsRight with positive values." $ do + let test = validateThickness $ Just [1,2,3] + in test `shouldSatisfy` isRight + it "validateThickness should be IsLeft with 0 or below values." $ do + let test = validateThickness $ Just [-10,3,0] + in test `shouldSatisfy` isLeft + it "validateIndex should be IsRight with more than 1 element." $ do + let test = validateIndex $ Just [1,2,3] + in test `shouldSatisfy` isRight + it "validateIndex should be IsLeft with no elements." $ do + let test = validateIndex $ Just [] + in test `shouldSatisfy` isLeft + it "validateCoordinates should be IsRight with equal vector lengths." $ do + let test = validateCoordinates [1.0,2.0,3.0] [4.0,5.0,6.0] + in test `shouldSatisfy` isRight + it "validateCoordinates should be IsLeft with unqual vector lengths." $ do + let test = validateCoordinates [1.0,2.0,3.0] [1.0,2.0] + in test `shouldSatisfy` isLeft + it "validateCoordinates3 should be IsRight with equal vector lengths." $ do + let test = validateCoordinates3 [1.0,2.0,3.0] [4.0,5.0,6.0] [7.0,8.0,9.0] + in test `shouldSatisfy` isRight + it "validateCoordinates3 should be IsLeft with unqual vector lengths." $ do + let test = validateCoordinates3 [1.0,2.0,3.0] [1.0,2.0] [1.0,2.0,3.0] + in test `shouldSatisfy` isLeft + it "validateRegion should be IsRight with all 2 letter words." $ do + let test = validateRegion ["AL","AZ"] + in test `shouldSatisfy` isRight + it "validateRegion should be IsRight with all 3 letter words." $ do + let test = validateRegion ["CAN","USA","MEX"] + in test `shouldSatisfy` isRight + it "validateRegion should be IsLeft with different word lengths." $ do + let test = validateRegion ["CAN","AL"] + in test `shouldSatisfy` isLeft + it "validateConn should be IsRight with symmetric matrix." $ do + let test = validateConn [[1.0,2.0,3.0],[4.0,5.0,6.0],[7.0,8.0,9.0]] + in test `shouldSatisfy` isRight + it "validateConn should be IsRight with node links." $ do + let test = validateConn [[1.0,2.0],[2.0,3.0],[3.0,4.0]] + in test `shouldSatisfy` isRight + it "validateConn should be IsRight with node links and weights." $ do + let test = validateConn [[1.0,2.0,0.6],[1.0,2.0,0.1]] + in test `shouldSatisfy` isRight + it "validateConn should be IsLeft with too many values in node pairing" $ do + let test = validateConn [[1.0,2.0,3.0,4.0]] + in test `shouldSatisfy` isLeft diff --git a/test/Web/LightningSpec.hs b/test/Web/LightningSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/LightningSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.LightningSpec where + +import Test.Hspec + +import Data.Maybe + +import Web.Lightning +import Web.Lightning.Session + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Lightning options API" $ do + it "allows setting Lightning's API base URL" $ do + let opts = setBaseURL "http://127.0.0.1:3000" defaultLightningOptions + in optHostUrl opts `shouldBe` "http://127.0.0.1:3000" + it "allows setting a session name" $ do + let opts = setSessionName "test" defaultLightningOptions + sess = fromJust $ optSession opts + in fromJust (snName sess) `shouldBe` "test" + it "allows setting a session id" $ do + let opts = setSessionId "abc-xyz" defaultLightningOptions + sess = fromJust $ optSession opts + in snId sess `shouldBe` "abc-xyz" + it "allows setting HTTP Basic Auth credentials" $ do + let opts = setBasicAuth ("user", "secret") defaultLightningOptions + (BasicAuth (_, p)) = optLoginMethod opts + in p `shouldBe` "secret"