sunroof-server 0.2 → 0.2.1
raw patch · 2 files changed
+60/−31 lines, 2 filesdep +scientificdep −attoparsecdep ~aesondep ~kansas-cometdep ~scotty
Dependencies added: scientific
Dependencies removed: attoparsec
Dependency ranges changed: aeson, kansas-comet, scotty, wai-middleware-static, warp
Files
- Language/Sunroof/Server.hs +52/−23
- sunroof-server.cabal +8/−8
Language/Sunroof/Server.hs view
@@ -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
sunroof-server.cabal view
@@ -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,