diff --git a/Language/Sunroof/Server.hs b/Language/Sunroof/Server.hs --- a/Language/Sunroof/Server.hs +++ b/Language/Sunroof/Server.hs @@ -46,13 +46,13 @@ ) where import Data.Aeson.Types ( Value(..), Object, Array ) -import Data.Attoparsec.Number ( Number(..) ) import Data.List ( intercalate ) -import Data.Text ( unpack ) +import Data.Text ( unpack, pack ) import Data.Proxy ( Proxy(..) ) import Data.Default ( Default(..) ) import Data.Semigroup import Data.Time.Clock +import Data.Scientific ( toRealFloat ) import qualified Data.Vector as V import qualified Data.HashMap.Strict as M import System.FilePath(()) @@ -60,16 +60,17 @@ import Control.Monad.IO.Class ( liftIO ) import Control.Concurrent.STM -import Network.Wai.Handler.Warp ( Port, settingsPort ) +import Network.Wai.Handler.Warp ( Port, setPort ) import Network.Wai.Middleware.Static import qualified Web.Scotty as SC -import Web.KansasComet +import Web.Scotty.Comet ( send, connect , Document, Options , kCometPlugin ) -import qualified Web.KansasComet as KC +import qualified Web.Scotty.Comet as KC import Language.Sunroof +import Language.Sunroof.JS.Args import Language.Sunroof.JavaScript ( Expr , literal, showExpr @@ -160,7 +161,7 @@ addCompileTime engine t0 t1 <- getCurrentTime - send (cometDocument engine) src -- send it, and forget it + send (cometDocument engine) (pack src) -- send it, and forget it addSendTime engine t1 return () @@ -168,9 +169,11 @@ -- The result value is given the corresponding Haskell type, -- if possible (see 'SunroofResult'). syncJS :: forall a t . (SunroofResult a) => SunroofEngine -> JS t a -> IO (ResultOf a) -syncJS engine jsm | typeOf (Proxy :: Proxy a) == Unit = do +{- +syncJS engine jsm | typesOf (Proxy :: Proxy a) == [Unit] = do _ <- syncJS engine (jsm >> return (0 :: JSNumber)) return $ jsonToValue (Proxy :: Proxy a) Null +-} syncJS engine jsm = do up <- newUplink engine t0 <- getCurrentTime @@ -179,7 +182,7 @@ up # putUplink v addCompileTime engine t0 t1 <- getCurrentTime - send (cometDocument engine) src + send (cometDocument engine) (pack src) addSendTime engine t1 t2 <- getCurrentTime -- There is *no* race condition in here. If no-one is listening, @@ -206,7 +209,7 @@ addCompileTime engine t0 t1 <- getCurrentTime - send (cometDocument engine) src + send (cometDocument engine) (pack src) addSendTime engine t1 t2 <- getCurrentTime @@ -301,7 +304,7 @@ -- Look into the example folder to see all of this in action. sunroofServer :: SunroofServerOptions -> SunroofApp -> IO () sunroofServer opts cometApp = do - let warpSettings = (SC.settings def) { settingsPort = cometPort opts } + let warpSettings = setPort (cometPort opts) (SC.settings def) -- Be quiet scotty! ... and beam me up! let scottyOptions = def { SC.verbose = 0 , SC.settings = warpSettings } @@ -372,14 +375,14 @@ data Downlink a = Downlink SunroofEngine (JSChan a) -- | Create a new downlink. -newDownlink :: forall a . (Sunroof a, SunroofArgument a) +newDownlink :: forall a . (SunroofArgument a) => SunroofEngine -> IO (Downlink a) newDownlink eng = do chan <- rsyncJS eng (newChan :: JSA (JSChan a)) return $ Downlink eng chan -- | Send data to the website. -putDownlink :: (Sunroof a, SunroofArgument a) +putDownlink :: (SunroofArgument a) => Downlink a -> JSA a -> IO () putDownlink (Downlink eng chan) val = asyncJS eng $ do v <- val @@ -387,7 +390,7 @@ -- | Request data in the downlink. This may block until -- data is available. -getDownlink :: (Sunroof a, SunroofArgument a) +getDownlink :: (SunroofArgument a) => Downlink a -> JSB a getDownlink (Downlink _eng chan) = readChan chan @@ -410,8 +413,10 @@ return $ Uplink eng u -- | Send Javascript data back to the server. -putUplink :: (Sunroof a) => a -> Uplink a -> JS t () -putUplink a (Uplink _ u) = kc_reply (js u) a +putUplink :: (SunroofArgument a) => a -> Uplink a -> JS t () +putUplink a (Uplink _ u) = + do o :: JSArgs a <- toJSArgs a + kc_reply (js u) o -- | Request data in the uplink. This may block until -- data is available. @@ -419,8 +424,12 @@ getUplink (Uplink eng u) = do val <- KC.getReply (cometDocument eng) u -- TODO: make this throw an exception if it goes wrong (I supose error does this already) - return $ jsonToValue (Proxy :: Proxy a) val - + return $ jsonToValue (Proxy :: Proxy (JSArgs a)) val +{- + case val of + (Array ss) -> return $ jsonToValue' (Proxy :: Proxy a) $ V.toList ss + _ -> error $ "getUplink: expecting Array, found " ++ show val +-} -- ------------------------------------------------------------- -- Comet Javascript API -- ------------------------------------------------------------- @@ -435,7 +444,7 @@ -- ----------------------------------------------------------------------- -- | Provides correspondant Haskell types for certain Sunroof types. -class (Sunroof a) => SunroofResult a where +class (SunroofArgument a) => SunroofResult a where -- | The Haskell value type associated with this 'Sunroof' type. type ResultOf a -- | Converts the given JSON value to the corresponding @@ -443,12 +452,21 @@ -- not be converted. jsonToValue :: Proxy a -> Value -> ResultOf a + jsonToValue' :: Proxy a -> [Value] -> ResultOf a + jsonToValue' _ [s] = jsonToValue (Proxy :: Proxy a) s + jsonToValue' _ ss = error $ "jsonToValue': JSON value is not a single element array : " ++ show ss + -- | @null@ can be translated to @()@. instance SunroofResult () where type ResultOf () = () jsonToValue _ (Null) = () jsonToValue _ v = error $ "jsonToValue: JSON value is not unit: " ++ show v + jsonToValue' _ [] = () + jsonToValue' _ [Null] = () -- not quite right yet + jsonToValue' _ ss = error $ "jsonToValue': JSON value is not a empty array : " ++ show ss + + -- | 'JSBool' can be translated to 'Bool'. instance SunroofResult JSBool where type ResultOf JSBool = Bool @@ -458,8 +476,7 @@ -- | 'JSNumber' can be translated to 'Double'. instance SunroofResult JSNumber where type ResultOf JSNumber = Double - jsonToValue _ (Number (I i)) = fromInteger i - jsonToValue _ (Number (D d)) = d + jsonToValue _ (Number scientific) = toRealFloat scientific jsonToValue _ v = error $ "jsonToValue: JSON value is not a number: " ++ show v -- | 'JSString' can be translated to 'String'. @@ -469,16 +486,28 @@ jsonToValue _ v = error $ "jsonToValue: JSON value is not a string: " ++ show v -- | 'JSArray' can be translated to a list of the 'ResultOf' the values. -instance forall a . SunroofResult a => SunroofResult (JSArray a) where +instance forall a . (Sunroof a, SunroofResult a) => SunroofResult (JSArray a) where type ResultOf (JSArray a) = [ResultOf a] jsonToValue _ (Array ss) = map (jsonToValue (Proxy :: Proxy a)) $ V.toList ss jsonToValue _ v = error $ "jsonToValue: JSON value is not an array : " ++ show v +-- ResultOf a ~ ResultOf (JSArgs a)) +instance forall a . SunroofResult a => SunroofResult (JSArgs a) where + type ResultOf (JSArgs a) = ResultOf a + jsonToValue _ (Array ss) = jsonToValue' (Proxy :: Proxy a) $ V.toList ss + jsonToValue _ v = error $ "jsonToValue: JSON value is not an array : " ++ show v + +instance forall a b . (Sunroof a, SunroofResult a, Sunroof b, SunroofResult b) => SunroofResult (a,b) where + type ResultOf (a,b) = (ResultOf a,ResultOf b) + jsonToValue _ (Array ss) = case V.toList ss of + [x1,x2] -> (jsonToValue (Proxy :: Proxy a) x1, jsonToValue (Proxy :: Proxy b) x2) + xs -> error $ "sonToValue: JSON value is not a 2-tuple : " ++ show xs + jsonToValue _ v = error $ "jsonToValue: JSON value is not an array : " ++ show v + -- | Converts a JSON value to a Sunroof Javascript expression. jsonToJS :: Value -> Expr jsonToJS (Bool b) = unbox $ js b -jsonToJS (Number (I i)) = unbox $ js i -jsonToJS (Number (D d)) = unbox $ js d +jsonToJS (Number scientific) = unbox $ js scientific jsonToJS (String s) = unbox $ js $ unpack s jsonToJS (Null) = unbox $ nullJS jsonToJS (Array arr) = jsonArrayToJS arr diff --git a/sunroof-server.cabal b/sunroof-server.cabal --- a/sunroof-server.cabal +++ b/sunroof-server.cabal @@ -1,5 +1,5 @@ Name: sunroof-server -Version: 0.2 +Version: 0.2.1 Synopsis: Monadic Javascript Compiler - Server Utilities Homepage: https://github.com/ku-fpg/sunroof-server Bug-reports: https://github.com/ku-fpg/sunroof-server @@ -21,20 +21,20 @@ Library Exposed-modules: Language.Sunroof.Server default-language: Haskell2010 - build-depends: aeson >= 0.5, - attoparsec >= 0.8.6.1, + build-depends: aeson >= 0.7 && < 0.8, + scientific >= 0.3.2 && < 0.4, vector >= 0.7.1, unordered-containers >= 0.1.3.0, base >= 4.3.1 && < 5, containers >= 0.4, data-default == 0.5.*, vector-space >= 0.8.6, - kansas-comet == 0.2, - wai-middleware-static >= 0.3.1 && < 0.4, - filepath >= 1.3 && < 1.4, - scotty >= 0.4.2 && < 0.5, + kansas-comet == 0.3.0, + wai-middleware-static >= 0.6 && < 0.7, + filepath >= 1.3 && < 1.4, + scotty >= 0.8 && < 0.9, semigroups >= 0.9, - warp >= 1.3.4.1, + warp >= 3.0 && < 3.1, stm >= 2.2, transformers == 0.3.*, text >= 0.11,