Skip to content
Permalink
Browse files

Update AngularJS example to work with Yesod 1.2.

  • Loading branch information
creichert committed Jun 23, 2014
1 parent edb196a commit 6dd9989c4232dabcd7eae977a2d3722a34605064
@@ -4,5 +4,8 @@ cabal-dev
*.hi
*.chi
*.chs.h
*.swp
*~
client_session_key.aes
cabal.sandbox.config
.cabal-sandbox/
*.swp
@@ -9,104 +9,115 @@ module Yesod.Angular
, addCtrl
, addCtrlRaw
, setDefaultRoute
, GAngular
, AngularT
) where

import Control.Applicative ((<$>))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Data.Aeson (FromJSON, ToJSON)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (First (..), Monoid (..))
import Data.Text (Text)
import Text.Hamlet (HtmlUrl, hamletFile)
import Text.Julius (JavascriptUrl, julius, juliusFile)
import Yesod.Core (GHandler, GWidget, RepHtml,
RepHtml (RepHtml), Route, Yesod,
addScriptEither, defaultLayout,
getUrlRenderParams, getYesod, lift,
lookupGetParam, newIdent,
sendResponse, toContent,
toWidget, whamlet)
import Yesod.Json (jsonToRepJson, parseJsonBody_)
import Language.Haskell.TH.Syntax (Q, Exp (AppE, LitE), Lit (StringL))
import Control.Applicative
import Data.Char (isAlpha)
import Control.Monad.Trans.Writer
import Data.Aeson
import qualified Data.Text as T
import Data.Char (isAlpha)
import Data.Map
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Text
import Language.Haskell.TH.Syntax (Q, Exp (AppE, LitE), Lit (StringL))
import Text.Hamlet
import Text.Julius
import Yesod

class Yesod master => YesodAngular master where
urlAngularJs :: master -> Either (Route master) Text
urlAngularJs _ = Right "//ajax.googleapis.com/ajax/libs/angularjs/1.0.2/angular.min.js"

wrapAngular :: Text -> GWidget sub master () -> GHandler sub master RepHtml
wrapAngular modname widget = defaultLayout [whamlet|<div ng-app=#{modname}>^{widget}|]
-- | YesodAngular wraps a widget in ng-app named @modname.
class Yesod site => YesodAngular site where
urlAngularJs :: site -> Either (Route site) Text
urlAngularJs _ = Right "//cdnjs.cloudflare.com/ajax/libs/angular.js/1.2.16/angular.min.js"

data AngularWriter sub master = AngularWriter
{ awCommands :: Map Text (GHandler sub master ())
, awPartials :: Map Text (HtmlUrl (Route master))
, awRoutes :: JavascriptUrl (Route master)
, awControllers :: JavascriptUrl (Route master)
wrapAngular :: Text -> WidgetT site IO () -> HandlerT site IO Html
wrapAngular modname widget = defaultLayout [whamlet| <div ng-app=#{modname}>^{widget} |]


data AngularWriter site = AngularWriter
{ awCommands :: Map Text (HandlerT site IO ())
, awPartials :: Map Text (HtmlUrl (Route site))
, awRoutes :: JavascriptUrl (Route site)
, awControllers :: JavascriptUrl (Route site)
, awDefaultRoute :: First Text
}
instance Monoid (AngularWriter sub master) where


type AngularT site = WriterT (AngularWriter site) (HandlerT site IO)


instance Monoid (AngularWriter site) where
mempty = AngularWriter mempty mempty mempty mempty mempty
AngularWriter a1 a2 a3 a4 a5
`mappend` AngularWriter b1 b2 b3 b4 b5
= AngularWriter
(mappend a1 b1)
(mappend a2 b2)
(mappend a3 b3)
(mappend a4 b4)
(mappend a5 b5)

type GAngular sub master = WriterT (AngularWriter sub master) (GHandler sub master)

runAngular :: YesodAngular master
=> GAngular sub master ()
-> GHandler sub master RepHtml
`mappend` AngularWriter b1 b2 b3 b4 b5 = AngularWriter
(mappend a1 b1)
(mappend a2 b2)
(mappend a3 b3)
(mappend a4 b4)
(mappend a5 b5)


-----------------------------------------------------------------------


runAngular :: YesodAngular site
=> AngularT site ()
-> HandlerT site IO Html
runAngular ga = do
master <- getYesod
site <- getYesod
((), AngularWriter{..}) <- runWriterT ga
mc <- lookupGetParam "command"
fromMaybe (return ()) $ mc >>= flip Map.lookup awCommands
mp <- lookupGetParam "partial"
case mp >>= flip Map.lookup awPartials of
Nothing -> return ()
Just htmlurl -> getUrlRenderParams >>= sendResponse . RepHtml . toContent . htmlurl
Just htmlurl -> do
ps <- getUrlRenderParams
let rep = toTypedContent . htmlurl $ ps
sendResponse rep

modname <- newIdent

let defaultRoute =
case awDefaultRoute of
First (Just x) -> [julius|.otherwise({redirectTo:"#{x}"})|]
First (Just x) -> [julius|.otherwise({redirectTo:"#{rawJS x}"})|]
First Nothing -> mempty

wrapAngular modname $ do
addScriptEither $ urlAngularJs master
[whamlet|<div ng-view>|]
addScriptEither $ urlAngularJs site
addScriptRemote "//cdnjs.cloudflare.com/ajax/libs/angular.js/1.2.16/angular-route.min.js"
[whamlet| <div ng-view> |]
toWidget [julius|
angular
.module("#{modname}", [])
.config(["$routeProvider", function($routeProvider) {
$routeProvider ^{awRoutes} ^{defaultRoute} ;
}]);
^{awControllers}
|]
angular.module("#{rawJS modname}", ['ngRoute']).config(["$routeProvider",
function($routeProvider, $locationProvider) {
$routeProvider ^{awRoutes} ^{defaultRoute};
}]);
^{awControllers}
|]


addCommand :: (FromJSON input, ToJSON output)
=> (input -> GHandler sub master output)
-> GAngular sub master Text
=> (input -> HandlerT site IO output)
-> AngularT site Text
addCommand f = do
name <- lift newIdent
tell mempty { awCommands = Map.singleton name handler }
return $ "?command=" `mappend` name
where
handler = do
input <- parseJsonBody_
input <- requireJsonBody
output <- f input
repjson <- jsonToRepJson output
repjson <- returnJson output
sendResponse repjson


setDefaultRoute :: Text -> AngularT site ()
setDefaultRoute x = tell mempty { awDefaultRoute = First $ Just x }


addCtrl :: Text -- ^ route pattern
-> Text -- ^ template name
-> Q Exp
@@ -119,18 +130,20 @@ addCtrl route name = do
return $ AppE p $ LitE $ StringL $ T.unpack t
fn suffix = T.unpack $ T.concat ["angular/", name, ".", suffix]


addCtrlRaw :: Text -- ^ user-friendly name
-> Text -- ^ route pattern
-> HtmlUrl (Route master) -- ^ template
-> JavascriptUrl (Route master) -- ^ controller
-> GAngular sub master ()
-> HtmlUrl (Route site) -- ^ template
-> JavascriptUrl (Route site) -- ^ controller
-> AngularT site ()
addCtrlRaw name' route template controller = do
name <- (mappend $ mappend name' "__") <$> lift newIdent
name <- mappend (mappend name' "__") <$> lift newIdent
tell mempty
{ awPartials = Map.singleton name template
, awRoutes = [julius|.when("#{route}", {controller:#{name}, templateUrl:"?partial=#{name}"})|]
, awControllers = [julius|var #{name} = ^{controller};|]
, awRoutes = [julius| .when("#{rawJS route}",
{ "controller": #{rawJS name}
, "templateUrl": "?partial=#{rawJS name}"
})
|]
, awControllers = [julius| var #{rawJS name} = ^{controller} |]
}

setDefaultRoute :: Text -> GAngular sub master ()
setDefaultRoute x = tell mempty { awDefaultRoute = First $ Just x }
@@ -1,14 +1,17 @@
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables, GeneralizedNewtypeDeriving, RecordWildCards #-}
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}
module Main (main) where

import Yesod
import Yesod.Static
import Yesod.Angular
import Data.IORef
import Data.Text (pack)
import Data.Map (Map)
import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
import Data.Map (Map)
import qualified Data.Map as Map
import Types
import Data.Text (pack)
import Text.Julius (rawJS)
import Types
import Yesod
import Yesod.Angular
import Yesod.Static

data App = App
{ getStatic :: Static
@@ -22,12 +25,9 @@ mkYesod "App" [parseRoutes|
|]

instance Yesod App
instance YesodAngular App where
urlAngularJs _ = Left $ StaticR $ StaticRoute ["angular", "angular.min.js"] []
instance YesodAngular App

type Angular = GAngular App App ()

handleHomeR :: Handler RepHtml
handleHomeR :: Handler Html
handleHomeR = runAngular $ do
cmdGetPeople <- addCommand $ \() -> do
people' <- getYesod >>= liftIO . readIORef . ipeople
@@ -57,4 +57,4 @@ main = do
s <- static "static"
p <- newIORef Map.empty
ni <- newIORef 1
warpDebug 3000 $ App s p ni
warp 3000 $ App s p ni
@@ -1,6 +1,6 @@
function($scope, $http, $location) {
$scope.addPerson = function(){
$http.post("#{cmdAddPerson}", $scope.newPerson).success(function(data){
$http.post("#{rawJS cmdAddPerson}", $scope.newPerson).success(function(data){
$location.path("/people/" + data[0]);
});
};
@@ -1,5 +1,5 @@
function($scope, $http) {
$http.post("#{cmdGetPeople}", []).success(function(data) {
$http.post("#{rawJS cmdGetPeople}", []).success(function(data) {
$scope.people = data;
});
}
@@ -1,5 +1,5 @@
function($scope, $routeParams, $http, $location) {
$http.post("#{cmdPersonDetail}", [$routeParams.personId]).success(function(data) {
$http.post("#{rawJS cmdPersonDetail}", [$routeParams.personId]).success(function(data) {
$scope.person = data;
}).error(function(){
$location.path("/people");

0 comments on commit 6dd9989

Please sign in to comment.
You can’t perform that action at this time.