diff --git a/yesod-angular/Types.hs b/yesod-angular/Types.hs new file mode 100644 index 0000000..9c0f517 --- /dev/null +++ b/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" diff --git a/yesod-angular/Yesod/Angular.hs b/yesod-angular/Yesod/Angular.hs new file mode 100644 index 0000000..ab84367 --- /dev/null +++ b/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|
^{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|
|] + 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 } diff --git a/yesod-angular/angular.hs b/yesod-angular/angular.hs new file mode 100644 index 0000000..fd574c6 --- /dev/null +++ b/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 diff --git a/yesod-angular/angular/add-person.hamlet b/yesod-angular/angular/add-person.hamlet new file mode 100644 index 0000000..143961d --- /dev/null +++ b/yesod-angular/angular/add-person.hamlet @@ -0,0 +1,9 @@ +
+