Initial yesod-angular

yesod-angular/Types.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
+module Types
+    ( PersonId (..)
+    , Person (..)
+    , PersonSummary (..)
+    , Singleton (..)
+    ) where
+
+import Data.Aeson (ToJSON (..), FromJSON (..), (.:), (.=), object, Value (Object, Array))
+import Data.Text (Text)
+import Control.Applicative ((<$>), (<*>))
+import qualified Data.Vector as V
+
+newtype PersonId = PersonId Text
+    deriving (ToJSON, FromJSON, Ord, Eq)
+
+data Person = Person Text Int
+instance ToJSON Person where
+    toJSON (Person name age) = object
+        [ "name" .= name
+        , "age" .= age
+        ]
+instance FromJSON Person where
+    parseJSON (Object o) = Person
+        <$> o .: "name"
+        <*> o .: "age"
+    parseJSON _ = fail "Expected an object"
+
+data PersonSummary = PersonSummary PersonId Text
+instance ToJSON PersonSummary where
+    toJSON (PersonSummary pid name) = object
+        [ "id" .= pid
+        , "name" .= name
+        ]
+
+newtype Singleton a = Singleton { unSingleton :: a }
+instance ToJSON a => ToJSON (Singleton a) where
+    toJSON = Array . V.singleton . toJSON . unSingleton
+instance FromJSON a => FromJSON (Singleton a) where
+    parseJSON (Array a) =
+        case V.toList a of
+            [x] -> Singleton <$> parseJSON x
+            _ -> fail "Not a single-element array"
+    parseJSON _ = fail "Not an array"

yesod-angular/Yesod/Angular.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Yesod.Angular
+    ( YesodAngular (..)
+    , runAngular
+    , addCommand
+    , addCtrl
+    , addCtrlRaw
+    , setDefaultRoute
+    , GAngular
+    ) 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 qualified Data.Text as T
+import Data.Char (isAlpha)
+
+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}|]
+
+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)
+    , awDefaultRoute :: First Text
+    }
+instance Monoid (AngularWriter sub master) 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
+runAngular ga = do
+    master <- 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
+
+    modname <- newIdent
+
+    let defaultRoute =
+            case awDefaultRoute of
+                First (Just x) -> [julius|.otherwise({redirectTo:"#{x}"})|]
+                First Nothing -> mempty
+
+    wrapAngular modname $ do
+        addScriptEither $ urlAngularJs master
+        [whamlet|<div ng-view>|]
+        toWidget [julius|
+angular
+    .module("#{modname}", [])
+    .config(["$routeProvider", function($routeProvider) {
+        $routeProvider ^{awRoutes} ^{defaultRoute} ;
+    }]);
+^{awControllers}
+|]
+
+addCommand :: (FromJSON input, ToJSON output)
+           => (input -> GHandler sub master output)
+           -> GAngular sub master Text
+addCommand f = do
+    name <- lift newIdent
+    tell mempty { awCommands = Map.singleton name handler }
+    return $ "?command=" `mappend` name
+  where
+    handler = do
+        input <- parseJsonBody_
+        output <- f input
+        repjson <- jsonToRepJson output
+        sendResponse repjson
+
+addCtrl :: Text -- ^ route pattern
+        -> Text -- ^ template name
+        -> Q Exp
+addCtrl route name = do
+    let name' = T.filter isAlpha name
+    [|addCtrlRaw $(liftT name') $(liftT route) $(hamletFile $ fn "hamlet") $(juliusFile $ fn "julius")|]
+  where
+    liftT t = do
+        p <- [|T.pack|]
+        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 ()
+addCtrlRaw name' route template controller = do
+    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};|]
+        }
+
+setDefaultRoute :: Text -> GAngular sub master ()
+setDefaultRoute x = tell mempty { awDefaultRoute = First $ Just x }

yesod-angular/angular.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables, 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 qualified Data.Map as Map
+import Types
+
+data App = App
+    { getStatic :: Static
+    , ipeople :: IORef (Map PersonId Person)
+    , nextId :: IORef Int
+    }
+
+mkYesod "App" [parseRoutes|
+/ HomeR
+/static StaticR Static getStatic
+|]
+
+instance Yesod App
+instance YesodAngular App where
+    urlAngularJs _ = Left $ StaticR $ StaticRoute ["angular", "angular.min.js"] []
+
+type Angular = GAngular App App ()
+
+handleHomeR :: Handler RepHtml
+handleHomeR = runAngular $ do
+    cmdGetPeople <- addCommand $ \() -> do
+        people' <- getYesod >>= liftIO . readIORef . ipeople
+        return $ map (\(pid, Person name _) -> PersonSummary pid name) $ Map.toList people'
+    $(addCtrl "/people" "people")
+
+    cmdPersonDetail <- addCommand $ \(Singleton pid) -> do
+        app <- getYesod
+        m <- liftIO $ readIORef $ ipeople app
+        case Map.lookup pid m of
+            Nothing -> notFound
+            Just p -> return p
+    $(addCtrl "/people/:personId" "person-detail")
+
+    cmdAddPerson <- addCommand $ \p -> do
+        app <- getYesod
+        i <- fmap (PersonId . pack . show) $ liftIO $ atomicModifyIORef (nextId app) $ \i -> (i + 1, i + 1)
+        () <- liftIO $ atomicModifyIORef (ipeople app) $ \m ->
+            (Map.insert i p m, ())
+        return $ Singleton i
+    $(addCtrl "/add-person" "add-person")
+
+    setDefaultRoute "/people"
+
+main :: IO ()
+main = do
+    s <- static "static"
+    p <- newIORef Map.empty
+    ni <- newIORef 1
+    warpDebug 3000 $ App s p ni

yesod-angular/angular/add-person.hamlet

@@ -0,0 +1,9 @@
+<form ng-submit=addPerson()>
+    <label>Name
+    <input type=text ng-model=newPerson.name>
+    <br>
+    <label>Age
+    <input type=number ng-model=newPerson.age>
+    <br>
+    <button>Add
+    <a href=#/people>Cancel

yesod-angular/angular/add-person.julius

@@ -0,0 +1,9 @@
+function($scope, $http, $location) {
+    $scope.addPerson = function(){
+        $http.post("#{cmdAddPerson}", $scope.newPerson).success(function(data){
+            $location.path("/people/" + data[0]);
+        });
+    };
+
+    $scope.newPerson = {"name":"Unnamed","age":25};
+}

yesod-angular/angular/people.hamlet

@@ -0,0 +1,6 @@
+<p>This is the people template
+<ul>
+    <li ng-repeat="person in people">
+        <a href=#/people/{{person.id}}>{{person.name}}
+<p>
+    <a href=#/add-person>Add a person

yesod-angular/angular/people.julius

@@ -0,0 +1,5 @@
+function($scope, $http) {
+    $http.post("#{cmdGetPeople}", []).success(function(data) {
+        $scope.people = data;
+    });
+}

yesod-angular/angular/person-detail.hamlet

@@ -0,0 +1,4 @@
+<p>Name: {{person.name}}
+<p>Age: {{person.age}}
+<p>
+    <a href=#/people>Return to people list

yesod-angular/angular/person-detail.julius

@@ -0,0 +1,7 @@
+function($scope, $routeParams, $http, $location) {
+    $http.post("#{cmdPersonDetail}", [$routeParams.personId]).success(function(data) {
+        $scope.person = data;
+    }).error(function(){
+        $location.path("/people");
+    });;
+}