diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Christopher Reichert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Christopher Reichert nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Yesod/Angular.hs b/src/Yesod/Angular.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Angular.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Yesod Angular JS Integration. +-- +-- This module is based on Michael Snoyman's original work +-- in the repository. +-- +-- * This module currently defaults to Angular 1.2.18. Use +-- `urlAngularJs_` specify your own Angular location. +-- * Example can be found at: +-- +-- * Currently, this module looks for controllers in the +-- `templates/angular` directory. +module Yesod.Angular + ( YesodAngular (..) + , runAngular + , addCommand + , addCtrl + , addCtrlRaw + , setDefaultRoute + , AngularT + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Writer (WriterT(..), tell) +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isAlpha) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, First(..), (<>), mempty, mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH.Syntax (Q, Exp (AppE, LitE), + Lit (StringL)) +import Text.Hamlet (hamletFile) +import Text.Julius (JavascriptUrl, juliusFile, rawJS) +import Yesod + + +-- | YesodAngular wraps a widget in ng-app named @modname. +class Yesod site => YesodAngular site where + -- | Default instance loads `angular.min.js` and `angular-route.min.js`. + urlAngularJs :: site -> [Either (Route site) Text] + urlAngularJs _ = [Right "//cdnjs.cloudflare.com/ajax/libs/angular.js/1.2.18/angular.min.js", + Right "//cdnjs.cloudflare.com/ajax/libs/angular.js/1.2.18/angular-route.min.js"] + + -- | 'wrapAngular' wraps @widget in an ng-app named @modname. + wrapAngular :: Text -> WidgetT site IO () -> HandlerT site IO Html + wrapAngular modname widget = defaultLayout [whamlet|
^{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 + } + + +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) + + +runAngular :: YesodAngular site + => AngularT site () + -> HandlerT site IO Html +runAngular ga = do + 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 -> do + ps <- getUrlRenderParams + let rep = toTypedContent . htmlurl $ ps + sendResponse rep + + modname <- newIdent + + let defaultRoute = + case awDefaultRoute of + First (Just x) -> [julius|.otherwise({redirectTo:"#{rawJS x}"})|] + First Nothing -> mempty + + wrapAngular modname $ do + mapM_ addScriptEither $ urlAngularJs site + [whamlet|
|] + toWidget [julius| + angular.module("#{rawJS modname}", ['ngRoute']).config(["$routeProvider", + function($routeProvider, $locationProvider) { + $routeProvider ^{awRoutes} ^{defaultRoute}; + }]); + ^{awControllers} + |] + + +addCommand :: (FromJSON input, ToJSON output) + => (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 <- requireJsonBody + output <- f input + 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 +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 site) -- ^ template + -> JavascriptUrl (Route site) -- ^ controller + -> AngularT site () +addCtrlRaw name' route template controller = do + name <- mappend (mappend name' "__") <$> lift newIdent + tell mempty + { awPartials = Map.singleton name template + , awRoutes = [julius| .when("#{rawJS route}", + { "controller": #{rawJS name} + , "templateUrl": "?partial=#{rawJS name}" + }) + |] + , awControllers = [julius| var #{rawJS name} = ^{controller} |] + } diff --git a/yesod-angular.cabal b/yesod-angular.cabal new file mode 100644 --- /dev/null +++ b/yesod-angular.cabal @@ -0,0 +1,33 @@ +name: yesod-angular +version: 0.1.0.0 +synopsis: Yesod AngularJS integration. +description: + Yesod AngularJS integration. + + This module is based on Michael Snoyman's original work + in the repository. +license: BSD3 +license-file: LICENSE +author: Christopher Reichert +maintainer: Christopher Reichert +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Yesod.Angular + default-language: Haskell2010 + build-depends: + aeson >= 0.6 && < 0.8 + , base == 4.* + , containers == 0.5.* + , shakespeare == 2.* + , template-haskell + , text >= 0.11 && < 2.0 + , transformers >= 0.2 + , yesod >= 1.2.5 && < 1.3 + +source-repository head + type: git + location: https://github.com/creichert/yesod-angular