packages feed

dingo-core (empty) → 0.0.2

raw patch · 29 files changed

+1647/−0 lines, 29 filesdep +SHAdep +aesondep +attoparsecsetup-changed

Dependencies added: SHA, aeson, attoparsec, base, base64-bytestring, blaze-builder, blaze-html, blaze-textual, bytestring, containers, cookie, deepseq, enumerator, fclabels, file-embed, hashable, http-types, random, shakespeare-js, strict-concurrency, template-haskell, text, transformers, unordered-containers, wai, wai-extra, warp, web-css

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2011 Bardur Arantsson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ dingo-core.cabal view
@@ -0,0 +1,81 @@+Name:                dingo-core+Version:             0.0.2+Synopsis:            Dingo is a Rich Internet Application platform based on the Warp web server.+Description:         Dingo is a Rich Internet Application platform based on the Warp web server. It allows you to write code which looks very much like regular GUI code and have it work in the browser. ++  This package contains the core modules.+License:             MIT+License-file:        LICENSE+Category:            WWW+Cabal-version:       >=1.6.0.1+Build-type:          Simple+Author:              Bardur Arantsson+Maintainer:          Bardur Arantsson <bardur@scientician.net>++Library+  Build-Depends: base == 4.*+               , aeson == 0.3.*+               , attoparsec >= 0.9.0.0 && < 0.10+               , base64-bytestring >= 0.1 && < 0.2+               , bytestring >= 0.9.0.1+               , blaze-builder >= 0.3 && <0.4+               , blaze-html >= 0.4.1.6 && < 0.5+               , blaze-textual >= 0.2 && < 0.3+               , containers >= 0.4+               , cookie >= 0.3.0 && < 0.4+               , deepseq >= 1.1 && < 1.2+               , enumerator >= 0.4 && < 0.5+               , file-embed >= 0.0.4 && < 0.1+               , fclabels == 1.0.*+               , hashable >= 1.1.0.0 && < 1.2+               , http-types == 0.6.*+               , random == 1.*+               , SHA >= 1.5 && < 1.6+               , shakespeare-js == 0.10.*+               , strict-concurrency >= 0.2.4 && < 0.3+               , template-haskell+               , text == 0.11.*+               , transformers >= 0.2.2 && < 0.3+               , unordered-containers >= 0.1.4 && < 0.2+               , wai == 0.4.*+               , wai-extra == 0.4.*+               , warp == 0.4.*+               , web-css == 0.1.*+  Extensions:          DeriveDataTypeable+                       ExistentialQuantification+                       FunctionalDependencies+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       OverloadedStrings+                       QuasiQuotes+                       TemplateHaskell+                       TypeOperators+  ghc-options:         -Wall+  hs-source-dirs:      src+  Exposed-modules:     Dingo.Callback+                       Dingo.Event+                       Dingo.ResourceBundle+                       Dingo.Selector+                       Dingo.Server+                       Dingo.Widget+                       Dingo.Widget.Application+  Other-modules:       Control.DeepSeq.ByteString+                       Dingo.Internal.Application+                       Dingo.Internal.Base+                       Dingo.Internal.Callback+                       Dingo.Internal.CallbackTypes+                       Dingo.Internal.Event+                       Dingo.Internal.EventTypes+                       Dingo.Internal.Html+                       Dingo.Internal.JavaScript+                       Dingo.Internal.Queue+                       Dingo.Internal.ResourceBundle.Internal+                       Dingo.Internal.ResourceBundle.Boot+                       Dingo.Internal.Server.State+                       Dingo.Internal.Server.Wai+                       Dingo.Internal.Session+                       Dingo.Internal.SessionTypes+                       Dingo.Internal.Widget+                       Dingo.Internal.WidgetSet+                       Dingo.Internal.WidgetTypes+
+ src/Control/DeepSeq/ByteString.hs view
@@ -0,0 +1,14 @@+module Control.DeepSeq.ByteString+       ( -- Just for the instances+       ) where++import Control.DeepSeq (NFData(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++-- Strict byte strings are already in WHNF.+instance NFData BS.ByteString++-- Conversion to strict chunks ensures WHNF.+instance NFData BSL.ByteString where+        rnf a = rnf (BSL.toChunks a)
+ src/Dingo/Callback.hs view
@@ -0,0 +1,21 @@+module Dingo.Callback+       ( CallbackM+       , addWidget+       , sendJavascript+       , setWidgetContents+       ) where++import Data.Text (Text)+import Dingo.Internal.Base (Command(..))+import Dingo.Internal.Callback (CallbackM, addCommand, addWidget)+import Dingo.Widget (Widget(..))+import Text.Blaze (Html)+import Text.Julius (JavascriptUrl)++-- | Set the widget contents to the given HTML element.+setWidgetContents :: Widget w s => w -> Html -> CallbackM ()+setWidgetContents w h = addCommand $ ReplaceWidgetChildren (getWidgetId w) h++-- | Send raw Javascript to the browser.+sendJavascript :: JavascriptUrl Text -> CallbackM ()+sendJavascript = addCommand . RawJavascript
+ src/Dingo/Event.hs view
@@ -0,0 +1,8 @@+module Dingo.Event+       ( Event(..)+       , onEvent+       , emitEvent+       ) where++import Dingo.Internal.EventTypes (Event(..))+import Dingo.Internal.Event (onEvent, emitEvent)
+ src/Dingo/Internal/Application.hs view
@@ -0,0 +1,49 @@+module Dingo.Internal.Application+       ( Application+       , mkApplication+       , setApplicationTitle+       ) where++import           Data.Aeson (Value, FromJSON(..), ToJSON(..), Value(..))+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Typeable (Typeable)+import           Dingo.Internal.Base (zeroWidgetId, Command(..))+import           Dingo.Internal.Callback (CallbackM, addCommand)+import           Dingo.Internal.Widget (Widget(..))+import           Text.Blaze (toHtml)+import           Text.Julius (julius)++-- | Application widget. There is exactly one instance of this widget+-- per client browser.+data Application = Application+                 deriving (Show, Typeable)++-- Empty state.+data ApplicationState = ApplicationState ()+                      deriving (Show, Typeable)++-- Need dummy instance.+instance FromJSON ApplicationState where+  parseJSON _ = return $ ApplicationState ()++-- Need dummy instance.+instance ToJSON ApplicationState where+  toJSON _ = Null++-- Widget instance. We don't really need anything except+-- the widget ID.+instance Widget Application ApplicationState where+  getWidgetId _ = zeroWidgetId -- Pre-rendered with this fixed id.+  renderWidget _ = toHtml T.empty+  encodeClientStateJs _ = [julius| null |]+  decodeClientStateJs _ = [julius| null |]+  showWidget _ _ = "Application"++-- Instance of the application widget.+mkApplication :: Application+mkApplication = Application++-- | Set application title.+setApplicationTitle :: Application -> Text -> CallbackM ()+setApplicationTitle _ title = addCommand $ SetTitle title
+ src/Dingo/Internal/Base.hs view
@@ -0,0 +1,86 @@+module Dingo.Internal.Base+       ( WidgetId+       , CallbackId+       , Command(..)+       , callbackIdParser+       , succCallbackId+       , succWidgetId+       , widgetIdParser+       , widgetIdToLazyText+       , zeroCallbackId+       , zeroWidgetId+       ) where++import           Data.Aeson (Value)+import           Data.Attoparsec (Parser)+import           Data.Attoparsec.Char8 (decimal)+import           Data.Hashable (Hashable(..))+import           Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder.Int as TLBI+import           Dingo.Internal.EventTypes (Event(..))+import           Dingo.Selector+import           Text.Blaze (Html, ToValue(..))+import           Text.Julius (JavascriptUrl, ToJavascript(..))++-- | Widget ID.+newtype WidgetId = WidgetId Int+                 deriving (Show, Eq, Ord)++succWidgetId :: WidgetId -> WidgetId+succWidgetId (WidgetId i) = WidgetId (i+1)++zeroWidgetId :: WidgetId+zeroWidgetId = WidgetId 0++widgetIdParser :: Parser WidgetId+widgetIdParser = fmap WidgetId decimal++widgetIdToLazyText :: WidgetId -> TL.Text+widgetIdToLazyText (WidgetId i) = TL.pack $ show i++-- Widget IDs are hashable+instance Hashable WidgetId where+  hash (WidgetId i) = hash i++-- Callback ID.+newtype CallbackId = CallbackId Int+                     deriving (Show, Eq, Ord)++-- Find successor callback ID.+succCallbackId :: CallbackId -> CallbackId+succCallbackId (CallbackId i) = CallbackId (i+1)++zeroCallbackId :: CallbackId+zeroCallbackId = CallbackId 0++callbackIdParser :: Parser CallbackId+callbackIdParser = fmap CallbackId decimal++-- Command for the browser.+data Command = CallbackBySelector Event Selector CallbackId+             | SetWidgetValue WidgetId Value+             | SetTitle Text+             | AppendToWidgetChildren WidgetId Html+             | ReplaceWidgetChildren WidgetId Html+             | HeadMerge Html+             | AddEncoderDecoderFunctions WidgetId (JavascriptUrl Text) (JavascriptUrl Text)+             | TriggerEvent WidgetId Event+             | RawJavascript (JavascriptUrl Text)++-- Convert widget ID to attribute value. Used for generating HTML.+instance ToValue WidgetId where+  toValue (WidgetId widgetId) = toValue $ 'i' : show widgetId++-- | Convert widget ID to Javascript value. The converted value+-- is guaranteed to not contain any characters requiring quoting+-- or escaping in Javascript, nor to contain any non-ASCII characters.+instance ToJavascript WidgetId where+  toJavascript (WidgetId i) = TLBI.decimal i++-- | Convert callback ID to Javascript value. The converted value+-- is guaranteed to not contain any characters requiring quoting+-- or escaping in Javascript, nor to contain any non-ASCII characters.+instance ToJavascript CallbackId where+  toJavascript (CallbackId i) = TLBI.decimal i+
+ src/Dingo/Internal/Callback.hs view
@@ -0,0 +1,63 @@+module Dingo.Internal.Callback+       ( CallbackT          -- re-export without constructors+       , CallbackM          -- re-export without constructors+       , CallbackState      -- re-export+       , addCommand         -- re-export+       , addWidget+       , registerCallback+       , runCallbackT       -- re-export+       ) where++import           Control.Monad (forM_, when)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans.Class (lift)+import           Data.Aeson (ToJSON(..))+import           Data.Typeable (typeOf, typeRepKey)+import           Dingo.Internal.Base (CallbackId, WidgetId, Command(..))+import           Dingo.Internal.CallbackTypes+import           Dingo.Internal.Html (mkHeadMerge)+import qualified Dingo.Internal.Session as S+import           Dingo.Internal.WidgetTypes++-- Register a callback.+registerCallback :: CallbackM () -> CallbackM CallbackId+registerCallback callback = CallbackT $+  -- Register the callback in the session and return its ID.+  lift $ S.registerCallback $ WrapCallback callback++-- | Add a new widget using a given parent. The widget is constructed+-- using the given function which receives the new widget's ID as a parameter.+addWidget :: (Widget w s, Widget w' s') => w' -> (WidgetId -> CallbackM (w, s)) -> CallbackM w+addWidget pw f = do+  -- Construct the widget.+  ((w,s),callbackState) <- lift $ S.addWidget $ \newWidgetId ->+    runCallbackT (f newWidgetId)+  -- Add all the commands from the widget construction.+  augmentState callbackState+  -- Register widget type if necessary.+  widgetTypeRepKey <- liftIO $ typeRepKey $ typeOf w+  registeredWidgetType <- lift $ S.registerWidgetType $ widgetTypeRepKey+  -- Register resource bundles and perform head merges if necessary.+  when registeredWidgetType $ do+    -- Which resources does this widget require?+    let requiredResources = widgetResources $ getWidgetType w+    -- Add all the resource bundles.+    forM_ requiredResources $ \resourceBundle -> do+      -- Register the bundle if necessary.+      bundleRegistered <- lift $ S.registerResourceBundle resourceBundle+      -- If we hadn't registered the bundle before, we'll need to do head+      -- merge.+      when bundleRegistered $+        forM_ (mkHeadMerge resourceBundle) $ \html ->+          addCommand $ HeadMerge html+    -- Head merge other content.+    addCommand $ HeadMerge $ headMergeContent $ getWidgetType w+  -- Append widget HTML to parent.+  addCommand $ AppendToWidgetChildren (getWidgetId pw) (renderWidget w)+  -- Serialize initial state to client.+  addCommand $ AddEncoderDecoderFunctions (getWidgetId w)+    (encodeClientStateJs $ getWidgetType w)+    (decodeClientStateJs $ getWidgetType w)+  addCommand $ SetWidgetValue (getWidgetId w) (toJSON s)+  -- Return the widget+  return w
+ src/Dingo/Internal/CallbackTypes.hs view
@@ -0,0 +1,76 @@+module Dingo.Internal.CallbackTypes+       ( CallbackState+       , CallbackM+       , CallbackT(..)+       , WrapCallback(..)+       , addCommand+       , augmentState+       , getCommands+       , mkSession+       , runCallbackT+       ) where++import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.State.Strict (StateT, runStateT)+import qualified Control.Monad.Trans.State.Strict as MTS+import qualified Data.Label as L+import           Data.Label.PureM (modify)+import           Data.Monoid (Monoid(..))+import           Data.Sequence (Seq, (|>))+import qualified Data.Sequence as S+import           Dingo.Internal.Base (Command(..))+import           Dingo.Internal.SessionTypes+import           Dingo.ResourceBundle (ResourceBundle)++-- Wrapper type to avoid cyclic type definition.+data WrapCallback = WrapCallback { unWrapCallback :: CallbackM () }++-- Define the session state.+data CallbackState =+  CallbackState { _csCommands :: Seq Command+                }++-- Callback state is a monoid.+instance Monoid CallbackState where+  mempty = CallbackState S.empty+  mappend (CallbackState s1) (CallbackState s2) = CallbackState $ s1 `mappend` s2++-- Define the monad transformer.+newtype CallbackT m a = CallbackT { unCallback :: StateT CallbackState m a }+    deriving (Functor, Monad)++-- CallbackT is a monad transformer.+instance MonadTrans CallbackT where+   lift m = CallbackT $ lift m++-- CallbackT where the underlying monad is a MonadIO is also a MonadIO.+instance (MonadIO m) => MonadIO (CallbackT m) where+  liftIO = lift . liftIO++-- Type alias for convenience.+type CallbackM = CallbackT (SessionT WrapCallback IO)++-- Generate accessors.+$(L.mkLabels [''CallbackState])++-- Create an empty session state.+mkSession :: CallbackM () -> [ResourceBundle] -> SessionState WrapCallback+mkSession main = mkSessionState (WrapCallback main)++-- Sort the stream of commands appropriately.+getCommands :: CallbackState -> Seq Command+getCommands = L.get csCommands++-- Run a callback computation and return the stream of commands+-- to send to the browser.+runCallbackT :: Monad m => CallbackT m a -> m (a, CallbackState)+runCallbackT (CallbackT callback) = runStateT callback mempty++-- Add a command to the callback.+addCommand :: Monad m => Command -> CallbackT m ()+addCommand command = CallbackT $ modify csCommands (|> command)++-- Augment state with a different callback state.+augmentState :: Monad m => CallbackState -> CallbackT m ()+augmentState st = CallbackT $ MTS.modify $ \s -> s `mappend` st
+ src/Dingo/Internal/Event.hs view
@@ -0,0 +1,24 @@+module Dingo.Internal.Event+       ( onEvent+       , emitEvent+       ) where++import Dingo.Internal.Base (Command(..))+import Dingo.Internal.EventTypes (Event(..))+import Dingo.Internal.WidgetTypes (Widget(..))+import Dingo.Internal.Callback (CallbackM, addCommand, registerCallback)+import Dingo.Selector (ToSelector(..))++-- | Emit an event notification for a widget. This function behaves+-- exactly as if the event had occurred in the browser.+emitEvent :: Widget w s => w -> Event -> CallbackM ()+emitEvent w e =+  -- This is a little weird, but we kind of have to round-trip+  -- to ensure that all our client-side attached handlers are "in sync".+  addCommand $ TriggerEvent (getWidgetId w) e++-- | Perform a callback when the given event triggers.+onEvent :: ToSelector a => a -> Event -> CallbackM () -> CallbackM ()+onEvent s e callback = do+  callbackId <- registerCallback callback+  addCommand $ CallbackBySelector e (toSelector s) callbackId
+ src/Dingo/Internal/EventTypes.hs view
@@ -0,0 +1,19 @@+module Dingo.Internal.EventTypes+       ( Event(..)+       ) where++import Text.Julius (ToJavascript(..))++-- | Event types.+data Event = OnClick+           | OnDblClick+           | OnChange+             deriving (Show)++-- | Convert an event to the Javascript identifer of the corresponding+-- jQuery function.+instance ToJavascript Event where+  toJavascript OnClick = "click"+  toJavascript OnChange = "change"+  toJavascript OnDblClick = "dblclick"+
+ src/Dingo/Internal/Html.hs view
@@ -0,0 +1,34 @@+module Dingo.Internal.Html+       ( mkHeadMerge+       ) where++import           Data.ByteString (ByteString)+import           Data.Maybe (mapMaybe)+import           Data.Monoid (Monoid(..))+import           Data.Text (Text, isSuffixOf)+import qualified Data.Text as T+import           Dingo.Internal.ResourceBundle.Internal (ResourceBundle, getResourceBundleContents)+import           Text.Blaze ((!), toValue)+import qualified Text.Blaze.Html4.Strict as H4+import qualified Text.Blaze.Html4.Strict.Attributes as A++-- Build head merge HTML content from a resource bundle.+mkHeadMerge :: ResourceBundle -> [H4.Html]+mkHeadMerge resourceBundle =+  mapMaybe headMerge directory+  where+    (guid, directory) = getResourceBundleContents resourceBundle++    path filePath = T.concat [ bundleRootUri, filePath ]++    bundleRootUri =+      T.concat ["/bundles/", guid, "/" ]++    headMerge :: (Text,ByteString) -> Maybe H4.Html+    headMerge (filePath, _) | ".css" `isSuffixOf` filePath =+      Just $ H4.link ! A.type_ "text/css" ! A.href (toValue $ path filePath) ! A.rel "stylesheet"+    headMerge (filePath, _) | ".js" `isSuffixOf` filePath =+      Just $ H4.script ! A.type_ "text/javascript" ! A.src (toValue $ path filePath) $ mempty+    headMerge (_,_) =+      mempty+
+ src/Dingo/Internal/JavaScript.hs view
@@ -0,0 +1,65 @@+module Dingo.Internal.JavaScript+       ( renderCommandsToJs+       ) where++import           Blaze.ByteString.Builder (toLazyByteString)+import           Data.Aeson (Value)+import           Data.Aeson.Encode (fromValue)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import           Data.Monoid (mconcat)+import           Data.Text (Text)+import qualified Data.Text as TS+import           Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import           Dingo.Internal.Base (Command(..))+import           Dingo.Selector (fromSelector)+import           Text.Blaze (Html, toHtml)+import           Text.Blaze.Renderer.Text (renderHtml)+import           Text.Julius (JavascriptUrl, ToJavascript(..), renderJavascriptUrl, julius)++-- Convert a JSON value to Javascript.+instance ToJavascript Value where+  toJavascript json =+    toJavascript $ decodeUtf8 $ toLazyByteString $ fromValue json++jsHtml :: Html -> TL.Text+jsHtml html = TLB.toLazyText $+  mconcat [ TLB.fromText "'"+          , TLB.fromLazyText $ renderHtml html     -- FIXME: Proper quoting+          , TLB.fromText "'"+          ]++-- Render julius for embedding into julius.+unJulius :: JavascriptUrl Text -> TL.Text+unJulius = renderJavascriptUrl (\_ _ -> TS.empty)++-- Render a command to Javascript.+renderCommandToJs :: Command -> JavascriptUrl Text+renderCommandToJs (CallbackBySelector ev selector callbackId) =+  [julius| $("#{TLB.toLazyText $ fromSelector selector}").#{ev}(function () {+                                               Dingo.callback(#{callbackId});+             }); |]+renderCommandToJs (SetWidgetValue widgetId value) =+  [julius| Dingo.setWidgetValue(#{widgetId}, #{value}); |]+renderCommandToJs (SetTitle title) =+  [julius| document.title = #{jsHtml $ toHtml title}; |]+renderCommandToJs (AppendToWidgetChildren widgetId html) =+  [julius| $("#i#{widgetId}").append(#{jsHtml html}); |]+renderCommandToJs (ReplaceWidgetChildren widgetId html) =+  [julius| $("#i#{widgetId}").html(#{jsHtml html}); |]+renderCommandToJs (HeadMerge html) =+  [julius| $("head").append(#{jsHtml html}); |]+renderCommandToJs (AddEncoderDecoderFunctions widgetId e d) =+  [julius| Dingo.addEncoder(#{widgetId}, #{unJulius e});+            Dingo.addDecoder(#{widgetId}, #{unJulius d}); |]+renderCommandToJs (TriggerEvent widgetId e) =+  [julius| $("#i#{widgetId}").trigger('#{e}'); |]+renderCommandToJs (RawJavascript js) =+  js++-- Render a list of commands to JavaScript+renderCommandsToJs :: [Command] -> ByteString+renderCommandsToJs cs =+  mconcat $ LBS.toChunks $ encodeUtf8 $ unJulius $ mconcat $ map renderCommandToJs cs
+ src/Dingo/Internal/Queue.hs view
@@ -0,0 +1,24 @@+module Dingo.Internal.Queue+       ( readChanTimeout+       ) where++import Control.Concurrent (forkIO, threadDelay, killThread, myThreadId)+import Control.Concurrent.Chan.Strict (Chan, readChan)+import Control.Concurrent.MVar.Strict (newEmptyMVar, putMVar, takeMVar)+import Control.DeepSeq (NFData)++-- Read a Chan with timeout.+readChanTimeout :: NFData a => Chan a -> Int -> IO (Maybe a)+readChanTimeout ch timeout = do+  result <- newEmptyMVar+  _ <- forkIO $ do+    wid <- myThreadId+    readerThreadId <- forkIO $ do+      x <- readChan ch+      killThread wid+      putMVar result (Just x)+    threadDelay timeout+    killThread readerThreadId+    putMVar result Nothing+  -- Block waiting for either timeout or the read.+  takeMVar result
+ src/Dingo/Internal/ResourceBundle/Boot.hs view
@@ -0,0 +1,30 @@+module Dingo.Internal.ResourceBundle.Boot+       ( bootResourceBundles+       ) where++import Dingo.ResourceBundle++jqueryDirectory :: ResourceDirectory+jqueryDirectory = $(embedDir "bundles/jquery")++jqueryResourceBundle :: ResourceBundle+jqueryResourceBundle = makeResourceBundle jqueryDirectory++json2Directory :: ResourceDirectory+json2Directory = $(embedDir "bundles/json2")++json2ResourceBundle :: ResourceBundle+json2ResourceBundle = makeResourceBundle json2Directory++bootstrapDirectory :: ResourceDirectory+bootstrapDirectory = $(embedDir "bundles/_bootstrap")++bootstrapResourceBundle :: ResourceBundle+bootstrapResourceBundle = makeResourceBundle bootstrapDirectory++bootResourceBundles :: [ResourceBundle]+bootResourceBundles =+  [ json2ResourceBundle+  , jqueryResourceBundle+  , bootstrapResourceBundle+  ]
+ src/Dingo/Internal/ResourceBundle/Internal.hs view
@@ -0,0 +1,89 @@+module Dingo.Internal.ResourceBundle.Internal+       ( ResourceBundle+       , ResourceBundleSet+       , ResourceDirectory+       , makeResourceBundle+       , elemResourceBundleSet+       , embedDir+       , findResourceInBundleSet+       , getResourceBundleContents+       , resourceBundleSetFromList+       ) where++import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import           Data.Digest.Pure.SHA (sha256, showDigest)+import           Data.FileEmbed+import qualified Data.Label as L+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import           Data.Monoid (Monoid(..))+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE++-- | Type alias for convience for using 'embedDir'.+type ResourceDirectory = [(String, ByteString)]++-- | Resource bundle data structure.+data ResourceBundle =+  ResourceBundle { _rbGUID :: Text+                 , _rbDirectory :: HashMap Text ByteString+                 }++$(L.mkLabels [''ResourceBundle])++-- | Map of resource bundles.+newtype ResourceBundleSet = ResourceBundleSet (HashMap Text ResourceBundle)++-- | Make a resource bundle from an embedded directory structure returned by 'embedDir'.+makeResourceBundle :: ResourceDirectory -> ResourceBundle+makeResourceBundle resourceDirectory =+  ResourceBundle guid resourceDirectory'+  where+    guid =+      T.pack $ showDigest $ sha256 $ BSL.concat $+      map (\(p,c) -> BSL.concat [ TLE.encodeUtf8 $ TL.pack p, BSL.fromChunks [c]]) $+      resourceDirectory+    resourceDirectory' =+      H.fromList $ map convertFilePath resourceDirectory+    convertFilePath (p,c) =+      (T.pack p, c)++-- Retrieve resource bundle contents.+getResourceBundleContents :: ResourceBundle -> (Text, [(Text,ByteString)])+getResourceBundleContents (ResourceBundle guid directory) =+  (guid, H.toList directory)++-- Create resource bundles structure from a list.+resourceBundleSetFromList :: [ResourceBundle] -> ResourceBundleSet+resourceBundleSetFromList =+  ResourceBundleSet . H.fromList . map (\i -> (L.get rbGUID i, i))++-- Find a path within a resource bundle.+findResource :: ResourceBundle -> Text -> Maybe ByteString+findResource bundle path =+  H.lookup path $ L.get rbDirectory bundle++-- Resource bundle set is a monoid.+instance Monoid ResourceBundleSet where+  mempty = ResourceBundleSet H.empty+  mappend (ResourceBundleSet a) (ResourceBundleSet b) = ResourceBundleSet (a `mappend` b)++-- Find a resource in a set of bundles.+findResourceInBundleSet ::  Text -> [Text] -> ResourceBundleSet -> Maybe ByteString+findResourceInBundleSet bundleId path (ResourceBundleSet resourceBundles) =+  case H.lookup bundleId resourceBundles of+    Nothing -> Nothing+    Just resourceBundle -> findResource resourceBundle path'+  where+    path' :: Text+    path' = T.intercalate "/" path++-- Check if a resource bundle exists in a resource bundle set.+elemResourceBundleSet :: ResourceBundle -> ResourceBundleSet -> Bool+elemResourceBundleSet x (ResourceBundleSet xs) =+  case H.lookup (L.get rbGUID x) xs of+    Nothing -> False+    Just _ -> True
+ src/Dingo/Internal/Server/State.hs view
@@ -0,0 +1,145 @@+module Dingo.Internal.Server.State+       ( ClientSession+       , ServerSessionState+       , ServerState+       , SessionId+       , cssClientSessionState+       , emptyServerState+       , getSession+       , getSessionId+       , handleCallback+       , readCommandWithTimeout+       , ssApplicationTitle+       , ssBootResourceBundles+       ) where++import           Control.Concurrent.Chan.Strict (Chan, newChan, writeChan)+import           Control.DeepSeq.ByteString ()+import           Control.Monad (replicateM)+import           Data.Aeson (Value(..))+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.Foldable as F+import           Data.HashMap.Strict (HashMap)+import           Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)+import qualified Data.Label as L+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Text (Text)+import           Dingo.Internal.Application (mkApplication, Application)+import           Dingo.Internal.Base (CallbackId, WidgetId)+import           Dingo.Internal.CallbackTypes (WrapCallback(..), CallbackM, mkSession, getCommands)+import           Dingo.Internal.JavaScript (renderCommandsToJs)+import           Dingo.Internal.Queue (readChanTimeout)+import           Dingo.Internal.ResourceBundle.Boot (bootResourceBundles)+import           Dingo.Internal.Session (SessionState, runSessionT, runCallback)+import           Dingo.ResourceBundle (ResourceBundle)+import           System.Random (Random(randomRIO))++-- Session ID identifies a session, i.e. identifies a client persistently+-- across requests.+type SessionId = ByteString++-- Type alias for shorter function signatures.+type ServerSessionState = SessionState WrapCallback++-- Client session state.+data ClientSessionState =+  ClientSessionState { _cssClientSessionState :: ServerSessionState+                     , _cssCommandsForClient :: Chan ByteString+                     }++$(L.mkLabels [''ClientSessionState])++-- Type alias for convenience.+-- TODO: We should probably make this abstract+type ClientSession = (SessionId, IORef ClientSessionState)++-- Server state.+data ServerState =+  ServerState { _ssClientSessions :: IORef (Map SessionId (IORef ClientSessionState))+              , _ssApplicationCallback :: CallbackM ()+              , _ssApplicationTitle :: Text+              , _ssBootResourceBundles :: [ResourceBundle]+              }++$(L.mkLabels [''ServerState])++-- Empty server state.+emptyServerState :: (Application -> CallbackM ()) -> Text -> [ResourceBundle] -> IO ServerState+emptyServerState applicationCallback applicationTitle resourceBundles = do+  clientSessions <- newIORef M.empty+  return $ ServerState clientSessions (applicationCallback mkApplication) applicationTitle (bootResourceBundles ++ resourceBundles)++-- Generate a session ID.+generateSessionId :: IO ByteString+generateSessionId = fmap toBase64 $ replicateM 16 $ randomRIO (0,255)+  where+    toBase64 = B64.encode . BS.pack . map fromInteger++-- Find or initialize session. If the returned session ID+-- does not match the input session ID, a new session was+-- created.+getSession :: ServerState -> Maybe SessionId -> IO ClientSession+getSession serverState mSessionId = do+  serverStateM <- readIORef $ L.get ssClientSessions serverState+  case mSessionId of+    Nothing -> newSession+    Just sessionId ->+      case M.lookup sessionId serverStateM of+        Nothing -> newSession+        Just sessionRef -> return (sessionId, sessionRef) -- Exists++  where++    newSession :: IO ClientSession+    newSession = do+      -- Generate a new session ID.+      sessionId <- generateSessionId+      -- Start up new session.+      let app = L.get ssApplicationCallback serverState+      let bundles = L.get ssBootResourceBundles serverState+      let sessionState = mkSession app bundles+      sessionChannel <- newChan+      sessionRef <- newIORef $ ClientSessionState sessionState sessionChannel+      -- Add session to the server state.+      atomicModifyIORef (L.get ssClientSessions serverState)+        (\m -> (M.insert sessionId sessionRef m, ()))+      -- Return the reference to the session.+      return (sessionId, sessionRef)++-- Get session ID.+getSessionId :: ClientSession -> SessionId+getSessionId = fst++-- Handle a callback.+handleCallback :: ServerState -> ClientSession -> CallbackId -> HashMap WidgetId Value -> IO ()+handleCallback serverState clientSession callbackId widgetStates = do+  -- Get the session reference.+  let clientSessionRef = snd clientSession+  session <- readIORef clientSessionRef+  -- Handle the request.+  let sessionState = L.get cssClientSessionState session+  (callbackState,sessionState') <-+    runSessionT sessionState $ runCallback callbackId widgetStates+  let commands = getCommands callbackState+  -- Add commands to the channel.+  let commandsChan = L.get cssCommandsForClient session+  writeChan commandsChan $ renderCommandsToJs $ F.toList commands+  -- Update the session reference.+  atomicModifyIORef clientSessionRef (\_ -> (ClientSessionState sessionState' commandsChan, ()))++-- Wait for a command to appear in the queue.+readCommandWithTimeout :: ServerState -> ClientSession -> Int -> IO (Maybe ByteString)+readCommandWithTimeout serverState clientSession timeout = do+  serverStateM <- readIORef $ L.get ssClientSessions serverState+  case M.lookup clientSessionId serverStateM of+    Nothing -> return Nothing+    Just sessionRef -> do+      commandsChan <- fmap (L.get cssCommandsForClient) $ readIORef sessionRef+      readChanTimeout commandsChan timeout++  where++    clientSessionId = fst clientSession
+ src/Dingo/Internal/Server/Wai.hs view
@@ -0,0 +1,184 @@+module Dingo.Internal.Server.Wai+       ( mkWaiApplication+       ) where++import           Blaze.ByteString.Builder (fromByteString, toByteString)+import           Control.DeepSeq.ByteString ()+import           Control.Monad (forM_)+import           Control.Monad.IO.Class (liftIO)+import           Data.Aeson (Value(..))+import qualified Data.Aeson.Parser as AEP+import           Data.Attoparsec (Parser)+import qualified Data.Attoparsec as AP+import           Data.ByteString (ByteString)+import           Data.Enumerator (Iteratee)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import           Data.IORef (readIORef)+import qualified Data.Label as L+import qualified Data.Map as M+import           Data.Maybe (fromMaybe, mapMaybe)+import           Data.Monoid (mempty)+import           Data.Text (Text)+import qualified Data.Text.Encoding as TE+import           Dingo.Internal.Base+import           Dingo.Internal.Html (mkHeadMerge)+import           Dingo.Internal.Server.State (ServerState, ClientSession, SessionId, ssApplicationTitle, ssBootResourceBundles, handleCallback, readCommandWithTimeout, getSession, getSessionId, cssClientSessionState)+import           Dingo.Internal.Session (lookupResource)+import           Dingo.ResourceBundle (ResourceBundle)+import           Network.HTTP.Types (statusOK, statusForbidden, headerContentType, Header, ResponseHeaders)+import           Network.Wai (Request(..), Response(..))+import qualified Network.Wai as W+import           Network.Wai.Parse (parseRequestBody, lbsSink)+import           Text.Blaze ((!), toHtml, unsafeByteStringValue)+import qualified Text.Blaze.Html4.Strict as H4+import qualified Text.Blaze.Html4.Strict.Attributes as A+import           Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)+import           Web.Cookie (SetCookie(..), parseCookies, renderSetCookie)++-- Set-cookie header.+headerSetCookie :: SetCookie -> Header+headerSetCookie s = ("Set-Cookie", toByteString $ renderSetCookie s)++-- Timeout for poll requests.+longPollTimeout :: Int+longPollTimeout = 30 * 1000 * 1000++-- JavaScript content type.+jsContentType :: ByteString+jsContentType = "text/javascript;charset=utf-8"++-- HTML content type.+htmlContentType :: ByteString+htmlContentType = "text/html;charset=utf-8"++-- Cookie name used for session ID.+cnSessionId :: ByteString+cnSessionId = "sessionId"++-- Make the session cookie.+-- TODO: Technically need UTF8 & URL-encoding for the sessionId parameter?!?+mkSessionCookie :: ByteString -> SetCookie+mkSessionCookie sessionId = SetCookie cnSessionId sessionId Nothing Nothing Nothing True++-- Empty "OK" response.+emptyOKResponse :: Response+emptyOKResponse = ResponseBuilder statusOK [] mempty++-- "Forbidden" response.+forbiddenResponse :: Response+forbiddenResponse = ResponseBuilder statusForbidden [] (fromByteString "Forbidden")++-- Index response.+indexResponse :: ServerState -> ResponseHeaders -> Response+indexResponse serverState responseHeaders = ResponseBuilder statusOK (headerContentType htmlContentType : responseHeaders) $ renderHtmlBuilder $ indexHtml applicationTitle resourceBundles+  where+    applicationTitle = L.get ssApplicationTitle serverState+    resourceBundles = L.get ssBootResourceBundles serverState++-- Bootstrap HTML page.+indexHtml :: Text -> [ResourceBundle] -> H4.Html+indexHtml applicationTitle resourceBundles =+  H4.html $ do+    H4.head $ do+      H4.title $ toHtml applicationTitle+      H4.meta ! A.httpEquiv "Content-Type" ! A.content (unsafeByteStringValue htmlContentType)+      forM_ resourceBundles $ \resourceBundle ->+        sequence_ $ mkHeadMerge resourceBundle+    H4.body $+      H4.div ! A.id "i0" $ mempty++-- Try to parse a text via UTF-8 encoding.+parseOnlyText :: Parser a -> Text -> Maybe a+parseOnlyText p s =+  case AP.parseOnly p $ TE.encodeUtf8 s of+    Left _ -> Nothing+    Right i -> Just i++-- Convert JSON encoded states to a mapping.+convertStateUpdates :: ByteString -> HashMap WidgetId Value+convertStateUpdates json =+  case AP.parseOnly AEP.value json of+    Left _ ->+      H.empty -- Error parsing; ignore.+    Right (Object o) ->+      H.fromList $ mapMaybe f $ M.toList o+    Right _ ->+      H.empty -- Invalid format; ignore.+  where+    f (k,v) =+      fmap (\i -> (i,v)) $ parseOnlyText widgetIdParser k++-- Callback server part.+callback :: ServerState -> Request -> ClientSession -> Text -> Iteratee ByteString IO Response+callback serverState request clientSession callbackIdStr =+  handle $ parseOnlyText callbackIdParser callbackIdStr+  where+    handle :: Maybe CallbackId -> Iteratee ByteString IO Response+    handle Nothing = return forbiddenResponse+    handle (Just callbackId) = do+      -- Post body contains URL-encoded data.+      (params, _) <- parseRequestBody lbsSink request+      let stateJson = fromMaybe "{}" $ lookup "state" params+      -- Get the state update portion of the form data.+      let stateUpdates = convertStateUpdates stateJson+      -- Handle the callback+      liftIO $ handleCallback serverState clientSession callbackId stateUpdates+      return emptyOKResponse++-- Long polling handler.+poll :: ServerState -> ClientSession -> Iteratee ByteString IO Response+poll serverState clientSession = do+  command <- liftIO $ readCommandWithTimeout serverState clientSession longPollTimeout+  let command_ = fromMaybe "" command+  return $ ResponseBuilder statusOK [headerContentType jsContentType] $ fromByteString command_++-- Generate SetCookie session header if necessary.+generateSessionSetCookie :: Maybe SessionId -> ClientSession -> Maybe SetCookie+generateSessionSetCookie Nothing clientSession = Just $ mkSessionCookie $ getSessionId clientSession+generateSessionSetCookie (Just sid) clientSession | (sid == getSessionId clientSession) = Nothing+                                                  | otherwise = Just $ mkSessionCookie $ getSessionId clientSession++-- Serve a bundle.+serveBundle :: ClientSession -> [Text] -> Iteratee ByteString IO Response+serveBundle _ [] = return forbiddenResponse+serveBundle clientSession (bundleId:path) = do+  clientSessionStateRef <- liftIO $ readIORef (snd clientSession)+  let serverSessionState = L.get cssClientSessionState clientSessionStateRef+  case lookupResource bundleId path serverSessionState of+    Nothing ->+      return forbiddenResponse+    Just contents ->+      return $ ResponseBuilder statusOK [] $ fromByteString contents++-- Warp server.+mkWaiApplication :: ServerState -> W.Application+mkWaiApplication serverState = loop+  where+    loop :: Request -> Iteratee ByteString IO Response+    loop request = do+      -- Extract the cookies.+      let cookies =+            parseCookies $+            fromMaybe "" $+            lookup "Cookie" $ requestHeaders request+      -- Find or create session.+      let sessionId = lookup cnSessionId cookies+      clientSession <- liftIO $ getSession serverState sessionId++      -- Detect if we've created/replaced the session.+      let sessionSetCookie = generateSessionSetCookie sessionId clientSession++      -- Generate response headers.+      let responseHeaders =+            case sessionSetCookie of+              Nothing -> [ ]+              Just s -> [ headerSetCookie s ]++      -- Process the request+      case pathInfo request of+        [] -> return $ indexResponse serverState responseHeaders+        ["poll"] -> poll serverState clientSession+        ["callback",cid] -> callback serverState request clientSession cid+        ("bundles":bundlePath) -> serveBundle clientSession bundlePath+        _  -> return forbiddenResponse
+ src/Dingo/Internal/Session.hs view
@@ -0,0 +1,41 @@+module Dingo.Internal.Session+       ( SessionT+       , SessionState+       , addWidget+       , getWidgetStateM+       , lookupResource -- Re-export+       , newWidgetId+       , registerCallback+       , registerResourceBundle+       , registerWidgetType+       , runCallback+       , runSessionT+       , setWidgetStateM+       ) where++import           Data.Aeson (Value)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import           Data.Label.PureM (modify)+import           Data.Monoid (Monoid(..))+import           Dingo.Internal.Base+import           Dingo.Internal.CallbackTypes+import           Dingo.Internal.SessionTypes+import           Dingo.Internal.WidgetSet++-- Run callback.+runCallback :: CallbackId -> HashMap WidgetId Value -> SessionT WrapCallback IO CallbackState+runCallback callbackId encodedStatesFromBrowser = SessionT $ do+  -- We'll update the state of all the widgets in response to the+  -- updates we've received from the browser.+  modify widgetSet+    (\cs -> H.foldrWithKey setWidgetStateJ cs encodedStatesFromBrowser)+  -- Find the callback.+  mcallback <- unSession $ lookupCallback callbackId+  case mcallback of+    Nothing ->+      -- Could not find callback; let's just fall back to doing nothing.+      return mempty+    Just callback ->+      -- Run the callback computation on an empty callback state.+      fmap snd $ unSession $ runCallbackT $ unWrapCallback callback
+ src/Dingo/Internal/SessionTypes.hs view
@@ -0,0 +1,154 @@+module Dingo.Internal.SessionTypes+       ( SessionState+       , SessionT(..)+       , addWidget+       , getWidgetStateM+       , lookupCallback+       , lookupResource+       , mkSessionState+       , newCallbackId+       , newWidgetId+       , registerCallback+       , registerResourceBundle+       , registerWidgetType+       , runSessionT+       , setWidgetStateM+       -- Accessors:+       , callbackCounter+       , widgetCounter+       , widgetSet+       ) where++import           Control.Monad (liftM, unless)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.State.Strict (StateT, runStateT)+import           Data.ByteString (ByteString)+import           Data.HashSet (HashSet)+import qualified Data.HashSet as S+import           Data.Label (mkLabels, (:->))+import qualified Data.Label as L+import           Data.Label.PureM (gets, puts, modify)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Monoid (mappend)+import           Data.Text (Text)+import           Dingo.Internal.Base (CallbackId, WidgetId, succCallbackId, succWidgetId, zeroCallbackId, zeroWidgetId)+import           Dingo.Internal.ResourceBundle.Internal (ResourceBundle, ResourceBundleSet, elemResourceBundleSet, findResourceInBundleSet, resourceBundleSetFromList)+import           Dingo.Internal.WidgetSet (WidgetSet, emptyWidgetSet, setWidgetState, getWidgetState)+import           Dingo.Internal.WidgetTypes (Widget)++-- Generalized session state with a user-defined callback+-- type.+data SessionState c =+  SessionState { _callbackCounter :: CallbackId+               , _widgetCounter :: WidgetId+               , _sessionCallbacks :: Map CallbackId c+               , _widgetSet :: WidgetSet+               , _widgetTypeSet :: HashSet Int+               , _resourceBundleSet :: ResourceBundleSet+               }++-- Define the session monad transformer.+newtype SessionT c m a = SessionT { unSession :: Session c m a }+    deriving (Functor, Monad)++-- Session base type.+type Session c = StateT (SessionState c)++-- Generate accessors.+$(mkLabels [''SessionState])++-- Empty session state.+mkSessionState :: c -> [ResourceBundle] -> SessionState c+mkSessionState c0 bootResourceBundles =+  -- We use successors as starting IDs to accomodate the bootstrap HTML and callback.+  SessionState cid1 wid1 bootstrapCallbacks emptyWidgetSet S.empty $ resourceBundleSetFromList bootResourceBundles+  where+    wid0 = zeroWidgetId  -- Pre-rendered main widget.+    wid1 = succWidgetId wid0+    cid0 = zeroCallbackId+    cid1 = succCallbackId cid0+    bootstrapCallbacks = M.singleton cid0 c0++-- SessionT is a monad transformer.+instance MonadTrans (SessionT c) where+   lift m = SessionT $ lift m++-- SessionT where the underlying monad is a MonadIO is also a MonadIO.+instance (MonadIO m) => MonadIO (SessionT w m) where+  liftIO = lift . liftIO++-- Run a SessionT computation.+runSessionT :: Monad m => SessionState c -> SessionT c m a -> m (a, SessionState c)+runSessionT s0 (SessionT s) = runStateT s s0++-- Increment a label value, returning the old value.+freshIdentifier :: Monad m => (a -> a) -> (SessionState c :-> a) -> SessionT c m a+freshIdentifier succ_ label = SessionT $ do+  i <- gets label+  puts label $ succ_ i+  return i++-- Generate a fresh callback ID.+newCallbackId :: Monad m => SessionT c m CallbackId+newCallbackId = freshIdentifier succCallbackId callbackCounter++-- Generate a fresh widget ID.+newWidgetId :: Monad m => SessionT c m WidgetId+newWidgetId = freshIdentifier succWidgetId widgetCounter++-- Register a callback in the session.+registerCallback :: Monad m => c -> SessionT c m CallbackId+registerCallback callback = SessionT $ do+  callbackId <- unSession newCallbackId+  -- Update the set of callbacks.+  modify sessionCallbacks (M.insertWith' const callbackId callback)+  -- Return the allocated callback ID.+  return callbackId++-- Check if a widget type is registered in the session,+-- and register it if not. Returns+-- true iff the bundle was not previously registered.+registerWidgetType :: (Monad m, Functor m) => Int -> SessionT c m Bool+registerWidgetType widgetTypeRepKey = SessionT $ do+  e <- fmap (S.member widgetTypeRepKey) $ gets widgetTypeSet+  unless e $ modify widgetTypeSet $ S.insert widgetTypeRepKey+  return $ not e++-- Register a resource bundle in the session. Returns+-- true iff the bundle was not previously registered.+registerResourceBundle :: (Monad m, Functor m) => ResourceBundle -> SessionT c m Bool+registerResourceBundle resourceBundle = SessionT $ do+  e <- fmap (elemResourceBundleSet resourceBundle) $ gets resourceBundleSet+  unless e $ modify resourceBundleSet (\x -> mappend x (resourceBundleSetFromList [resourceBundle]))+  return $ not e++-- Look a resource up in the session.+lookupResource :: Text -> [Text] -> SessionState c -> Maybe ByteString+lookupResource bundleId path sessionState =+  findResourceInBundleSet bundleId path r+  where+    r = L.get resourceBundleSet sessionState++-- Look a callback up in the session.+lookupCallback :: (Monad m) => CallbackId -> SessionT c m (Maybe c)+lookupCallback callbackId = SessionT $ liftM (M.lookup callbackId) $ gets sessionCallbacks++-- Create a new widget with the given construction function.+addWidget :: Widget w s => (WidgetId -> SessionT b IO ((w, s), a)) -> SessionT b IO ((w, s), a)+addWidget f = do+  widgetId <- newWidgetId                          -- Fresh ID+  ((c,s),a) <- f widgetId                          -- Construct+  SessionT $ modify widgetSet (setWidgetState c s)   -- Register+  return ((c,s),a)++-- Get the current widget state.+getWidgetStateM :: (Monad m, Widget w s) => w -> SessionT b m (Maybe s)+getWidgetStateM c = SessionT $ do+  cs <- gets widgetSet+  return $ getWidgetState cs c++-- Set the current widget state.+setWidgetStateM :: (Monad m, Widget w s) => w -> s -> SessionT b m ()+setWidgetStateM c s = SessionT $ modify widgetSet (setWidgetState c s)
+ src/Dingo/Internal/Widget.hs view
@@ -0,0 +1,34 @@+module Dingo.Internal.Widget+       ( getWidgetState+       , setWidgetState+       , widgetSelector+         -- Re-export+       , Widget(..)+       ) where++import           Control.Monad.Trans.Class (lift)+import           Data.Aeson (ToJSON(..))+import qualified Data.Text.Lazy as TL+import           Dingo.Selector+import           Dingo.Internal.Base (Command(..), widgetIdToLazyText)+import           Dingo.Internal.Callback (CallbackM, addCommand)+import qualified Dingo.Internal.Session as S+import           Dingo.Internal.WidgetTypes++-- | Widget selector.+widgetSelector :: (Widget w s) => w -> SimpleSelector+widgetSelector w = anyElement `withId` TL.concat ["i", widgetIdToLazyText $ getWidgetId w]++-- | Update the value of a widget. This function pushes+-- the new value to the browser.+setWidgetState :: Widget w s => w -> s -> CallbackM ()+setWidgetState c s = do+  -- Update the session's idea of what the widget state is.+  lift $ S.setWidgetStateM c s+  -- Serialize to client.+  addCommand $ SetWidgetValue (getWidgetId c) (toJSON s)++-- | Get the current value of widget.+getWidgetState :: Widget w s => w -> CallbackM (Maybe s)+getWidgetState c = lift $ S.getWidgetStateM c+
+ src/Dingo/Internal/WidgetSet.hs view
@@ -0,0 +1,57 @@+module Dingo.Internal.WidgetSet+       ( WidgetSet+       , emptyWidgetSet+       , getWidgetState+       , setWidgetState+       , setWidgetStateJ+       ) where++import           Data.Aeson (Value, Result(..), fromJSON)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import           Data.Typeable (cast)+import           Dingo.Internal.Base+import           Dingo.Internal.WidgetTypes (Widget(..))++-- Existential wrapper type for widgets to be able to store them homogeneously.+data StateBox w = forall s . (Widget w s, Show w) => StateBox (w, s)++data WidgetBox = forall w . WidgetBox (StateBox w)++-- Show instance for WidgetBox.+instance Show WidgetBox where+  show (WidgetBox (StateBox (w,s))) = showWidget w s++-- WidgetSet data type.+newtype WidgetSet = WidgetSet { unWidgetSet :: HashMap WidgetId WidgetBox }+                  deriving (Show)++-- The empty widget set.+emptyWidgetSet :: WidgetSet+emptyWidgetSet = WidgetSet H.empty++-- Set a widget's state.+setWidgetState :: (Widget w s, Show w) => w -> s -> WidgetSet -> WidgetSet+setWidgetState w s (WidgetSet ws) =+  WidgetSet $ H.insert (getWidgetId w) (WidgetBox (StateBox (w,s))) ws++-- Set a widget's state from a JSON object.+setWidgetStateJ :: WidgetId -> Value -> WidgetSet -> WidgetSet+setWidgetStateJ widgetId j (WidgetSet ws) =+  WidgetSet $ H.adjust (update j) widgetId ws+  where+    update :: Value -> WidgetBox -> WidgetBox+    update json (WidgetBox (StateBox (w0,s0))) =+      WidgetBox (StateBox (w0, f $ fromJSON json))+        where+          f (Error _) = s0 -- Couldn't convert JSON; leave state unmodified.+          f (Success s) = s -- Set state.++-- Get a widget's state.+getWidgetState :: (Show w, Widget w s) => WidgetSet -> w -> Maybe s+getWidgetState ws w =+  case H.lookup (getWidgetId w) $ unWidgetSet ws of+    Nothing -> Nothing+    Just (WidgetBox (StateBox (_, s))) -> cast s++
+ src/Dingo/Internal/WidgetTypes.hs view
@@ -0,0 +1,48 @@+module Dingo.Internal.WidgetTypes+       ( Widget(..)+       , WidgetType -- Don't export constructor+       , getWidgetType+       ) where++import Data.Aeson.Types (FromJSON, ToJSON)+import Data.Monoid (mempty)+import Data.Text (Text)+import Data.Typeable (Typeable(..))+import Dingo.Internal.Base (WidgetId)+import Dingo.ResourceBundle (ResourceBundle)+import Text.Blaze (Html)+import Text.Julius (JavascriptUrl)++-- Type class for widgets. Widgets have an associated state type.+class (Typeable c, Typeable s, Show c, FromJSON s, ToJSON s) => Widget c s | c -> s where+  -- | Get the widget ID.+  getWidgetId :: c -> WidgetId+  -- | Render widget to HTML.+  renderWidget :: c -> Html+  -- | Return a JavaScript function to encode state in client to JSON.+  -- The function returned MUST be a nullary function which is invoked+  -- with @this@ set to a jQuery query result containing the widget.+  encodeClientStateJs :: WidgetType c -> JavascriptUrl Text+  -- | Return a JavaScript function to decode state received from the server by+  -- the client. The function receives the encoded state and must+  -- update the client-side widget. The @this@ reference will be a jQuery+  -- query result containing the widget.+  decodeClientStateJs :: WidgetType c -> JavascriptUrl Text+  -- | Print for debugging.+  showWidget :: c -> s -> String+  -- | Supply content for head merge when a widget of type w is first+  -- added to the application.+  headMergeContent :: WidgetType c -> Html+  headMergeContent _ = mempty+  -- | Resources required by a widget of this type.+  widgetResources :: WidgetType c -> [ResourceBundle]+  widgetResources _ = []++-- A type tag for widgets used to make the WidgetMeta type class+-- safer. The phantom type wrapper prevents inappropriate access to+-- widget state.+data WidgetType w = WidgetType ()++-- Get the widget type of a widget.+getWidgetType :: (Widget w s) => w -> WidgetType w+getWidgetType _ = WidgetType ()
+ src/Dingo/ResourceBundle.hs view
@@ -0,0 +1,26 @@+-- | This module is used to embed resource bundles+-- for use by widgets and applications.+--+-- Typical usage looks like:+--+-- > import Dingo.ResourceBundle+-- >+-- > myResourceDirectory :: ResourceDirectory+-- > myResourceDirectory = $(embedDir "bundles/my-resources")+-- >+-- > myResourceBundle :: ResourceBundle+-- > myResourceBundle = makeResourceBundle myResourceDirecory+--+-- You can then use @myResourceBundle@ as a resource bundle in+-- a widget or supply it in the application settings when starting+-- the Dingo server.+--++module Dingo.ResourceBundle+       ( ResourceBundle+       , ResourceDirectory+       , makeResourceBundle+       , embedDir -- Re-export from embed-file+       ) where++import Dingo.Internal.ResourceBundle.Internal
+ src/Dingo/Selector.hs view
@@ -0,0 +1,187 @@+module Dingo.Selector+       ( RefinableSelector+       , Selector+       , SimpleSelector+       , ToSelector(..)+       , (.>*.)+       , (.+.)+       , (.>.)+       , (.~.)+       , anyElement+       , element+       , fromSelector+       , with+       , withId+       , withClass+       , withAttribute+       , withAttributeValue+       , withAttributeValueElement+       , withAttributeValuePrefix+       ) where++import Data.Monoid (mconcat)+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder (Builder, fromLazyText)+import Web.CSS.Escaping (escapeIdentifier, escapeString)++-- JQuery Selectors.+data TypeOrUniversal = SAny                      -- Universal selector+                     | SType Text                -- Type selector++data Qualifier = SAttributePresent Text+               | SAttributeEquals Text Text+               | SSpacedAttributeContains Text Text+               | SHypenatedAttributeContains Text Text+               | SClass Text+               | SId Text++renderQualifier :: Qualifier -> Builder+renderQualifier (SAttributePresent a) =+  mconcat [ "["+          , fromLazyText $ escapeIdentifier a+          , "]"+          ]+renderQualifier (SAttributeEquals a v) =+  mconcat [ "["+          , fromLazyText $ escapeIdentifier a+          , "="+          , fromLazyText $ escapeString v+          , "]"+          ]+renderQualifier (SSpacedAttributeContains a v) =+  mconcat [ "["+          , fromLazyText $ escapeIdentifier a+          , "~="+          , fromLazyText $ escapeString v+          , "]"+          ]+renderQualifier (SHypenatedAttributeContains a v) =+  mconcat [ "["+          , fromLazyText $ escapeIdentifier a+          , "|="+          , fromLazyText $ escapeString v+          , "]"+          ]+renderQualifier (SClass c) =+  mconcat [ "."+          , fromLazyText $ escapeIdentifier c+          ]+renderQualifier (SId i) =+  mconcat [ "#"+          , fromLazyText $ escapeIdentifier i+          ]++newtype Discriminators = Discriminators [Qualifier]++data SimpleSelector = SimpleSelector TypeOrUniversal Discriminators++-- | Match a particular element type.+element :: Text -> SimpleSelector+element e = SimpleSelector (SType e) (Discriminators [])++-- | Match any element.+anyElement :: SimpleSelector+anyElement = SimpleSelector SAny (Discriminators [])++-- | Match by HTML/XML element ID.+withId :: RefinableSelector a => a -> Text -> a+withId s i = with s $ SId i++-- | Match by HTML class.+withClass :: RefinableSelector a => a -> Text -> a+withClass s c = with s $ SClass c++-- | Match by attribute presence+withAttribute :: RefinableSelector a => a -> Text -> a+withAttribute r a = with r $ SAttributePresent a++-- | Match by attribute value.+withAttributeValue :: RefinableSelector a => a -> Text -> Text -> a+withAttributeValue r a v = with r $ SAttributeEquals a v++-- | Match by value contained in a space-separated attribute value.+withAttributeValueElement :: RefinableSelector a => a -> Text -> Text -> a+withAttributeValueElement r a v = with r $ SSpacedAttributeContains a v++-- | Match by value at the left of a hyphen-separated attribute value.+withAttributeValuePrefix :: RefinableSelector a => a -> Text -> Text -> a+withAttributeValuePrefix r a v = with r $ SHypenatedAttributeContains a v++-- | A selector that can be refined.+class RefinableSelector a where+  with :: a -> Qualifier -> a++instance RefinableSelector Discriminators where+  with (Discriminators a) aop = Discriminators (aop:a)++instance RefinableSelector SimpleSelector where+  with (SimpleSelector tou discriminators) aop =+    SimpleSelector tou (with discriminators aop)++--+data Selector = SSimple SimpleSelector+              | SDescendant SimpleSelector Selector+              | SChild SimpleSelector Selector+              | SAdjacent SimpleSelector Selector+              | SFollowing SimpleSelector Selector++fromTypeOrUniversal :: TypeOrUniversal -> Builder+fromTypeOrUniversal SAny = "*"+fromTypeOrUniversal (SType e) = fromLazyText $ escapeIdentifier e++fromSimpleSelector :: SimpleSelector -> Builder+fromSimpleSelector (SimpleSelector tou (Discriminators qualifiers)) =+  mconcat [ fromTypeOrUniversal tou+          , mconcat $ map renderQualifier qualifiers ]++fromSelector :: ToSelector a => a -> Builder+fromSelector = go . toSelector+  where+    go (SSimple s) = fromSimpleSelector s+    go (SDescendant s r) = mconcat [fromSimpleSelector s, " ", go r]+    go (SChild s r) = mconcat [fromSimpleSelector s, ">", go r]+    go (SAdjacent s r) = mconcat [fromSimpleSelector s, "+", go r]+    go (SFollowing s r) = mconcat [fromSimpleSelector s, "~", go r]++-- Class for default conversions "upwards" in the ADT hierarchy.+class ToSelector a where+  toSelector :: a -> Selector++instance ToSelector Qualifier where+  toSelector a = toSelector $ SimpleSelector SAny (Discriminators [a])++instance ToSelector SimpleSelector where+  toSelector = SSimple++instance ToSelector Selector where+  toSelector = id++class ToSimpleSelector a where+  toSimpleSelector :: a -> SimpleSelector++instance ToSimpleSelector SimpleSelector where+  toSimpleSelector = id++-- | Descendant combinator.+(.>*.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector+(.>*.) s d = SDescendant (toSimpleSelector s) (toSelector d)++infixr .>*.++-- | Child combinator.+(.>.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector+(.>.) s d = SChild (toSimpleSelector s) (toSelector d)++infixr .>.++-- | Adjacent combinator.+(.+.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector+(.+.) s d = SAdjacent (toSimpleSelector s) (toSelector d)++infixr .+.++-- | Following combinator.+(.~.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector+(.~.) s d = SFollowing (toSimpleSelector s) (toSelector d)++infixr .~.
+ src/Dingo/Server.hs view
@@ -0,0 +1,43 @@+module Dingo.Server+       ( -- Settings:+         DingoSettings+       , defaultDingoSettings+       , dsPort+       , dsResourceBundles+         -- Functions:+       , runApplication+       ) where++import Data.Text (Text)+import Dingo.Internal.Application (Application)+import Dingo.Internal.Callback (CallbackM)+import Dingo.Internal.Server.State (emptyServerState)+import Dingo.Internal.Server.Wai (mkWaiApplication)+import Dingo.ResourceBundle (ResourceBundle)+import Network.Wai.Handler.Warp (runSettings, defaultSettings, Settings(..))++-- | Settings for the Dingo application. This is kept+-- as an abstract type to avoid breaking applications+-- when fields are added. You should use record syntax+-- to change the defaults, e.g.+--+-- > defaultDingoSettings { dsPort = 4900 }+data DingoSettings =+  DingoSettings { dsPort :: Int -- ^ Port to listen on. Default value: 3000+                , dsResourceBundles :: [ResourceBundle] -- ^ Starting resource bundles. Default value: []+                }++-- | Default settings for the Dingo application.+defaultDingoSettings :: DingoSettings+defaultDingoSettings = DingoSettings 3000 []++-- | Run the application with the given settings.+runApplication :: DingoSettings -> Text -> (Application -> CallbackM ()) ->IO ()+runApplication dingoSettings applicationTitle application = do+  serverState <- emptyServerState application applicationTitle $ dsResourceBundles dingoSettings+  runSettings settings $ mkWaiApplication serverState+  where+    settings =+      defaultSettings { settingsTimeout = 60+                      , settingsPort = dsPort dingoSettings+                      }
+ src/Dingo/Widget.hs view
@@ -0,0 +1,13 @@+-- | Module which defines the Widget data type+-- and operations which apply to all widgets.++module Dingo.Widget+       ( Widget(..)+       , WidgetId+       , getWidgetState+       , setWidgetState+       , widgetSelector+       ) where++import Dingo.Internal.Base (WidgetId)+import Dingo.Internal.Widget (Widget(..), getWidgetState, setWidgetState, widgetSelector)
+ src/Dingo/Widget/Application.hs view
@@ -0,0 +1,9 @@+-- | Module which defines the Application widget+-- and operations on it.++module Dingo.Widget.Application+       ( Application+       , setApplicationTitle+       ) where++import Dingo.Internal.Application (Application, setApplicationTitle)