diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Daniel Patterson + +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 Daniel Patterson 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/snaplet-lss.cabal b/snaplet-lss.cabal new file mode 100644 --- /dev/null +++ b/snaplet-lss.cabal @@ -0,0 +1,38 @@ +name: snaplet-lss +version: 0.1.0.0 +synopsis: Lexical Style Sheets - Snap Web Framework adaptor. +homepage: https://github.com/dbp/lss +license: BSD3 +license-file: LICENSE +author: Daniel Patterson +maintainer: dbp@dbpmail.net +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base >=4.7 && <4.8, + lss >= 0.1 && < 0.2, + xmlhtml >= 0.1 && < 0.3, + heist, + snap, + text, + directory, + filepath + hs-source-dirs: src/ + exposed-modules: + Snap.Snaplet.Lss + default-language: Haskell2010 + +Test-Suite test-snaplet-lss + type: exitcode-stdio-1.0 + hs-source-dirs: spec + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.6 && < 4.8, + snap, + lens, + text, + hspec-snap, + hspec2 + build-depends: snaplet-lss == 0.1.0.0 diff --git a/spec/Main.hs b/spec/Main.hs new file mode 100644 --- /dev/null +++ b/spec/Main.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +---------------------------------------------------------- +-- Section 0: Imports. -- +---------------------------------------------------------- +import Control.Lens +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Snap (Handler, Method (..), Snaplet, addRoutes, + makeSnaplet, nestSnaplet, route, + subSnaplet) +import Snap.Snaplet.Heist + +import Test.Hspec +import Test.Hspec.Snap + +import Snap.Snaplet.Lss + +---------------------------------------------------------- +-- Section 1: Example application used for testing. -- +---------------------------------------------------------- + +data App = App { _heist :: Snaplet (Heist App), _lss :: Snaplet Lss } + +makeLenses ''App + +instance HasHeist App where + heistLens = subSnaplet heist + +routes = [("test", render "test") + ,("test2", render "test2")] + +app = makeSnaplet "app" "An snaplet example application." Nothing $ do + addRoutes routes + h <- nestSnaplet "" heist $ heistInit "templates" + l <- nestSnaplet "" lss $ initLss h + return $ App h l + + +---------------------------------------------------------- +-- Section 2: Test suite against application. -- +---------------------------------------------------------- + +main :: IO () +main = hspec $ snap (route routes) app $ do + describe "basic tests" $ do + it "should have style tag when applying function" $ do + p <- get "/test" + p `shouldHaveSelector` "style" + p `shouldHaveText` "background-color" + p `shouldHaveText` "red" + it "should substitute params into css rules" $ do + p <- get "/test2" + -- NOTE(dbp 2014-09-04): The CSS library renders with odd spacing and treatment of numbers. + p `shouldHaveText` "font-size : 10.0em" diff --git a/src/Snap/Snaplet/Lss.hs b/src/Snap/Snaplet/Lss.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Lss.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +module Snap.Snaplet.Lss (Lss(..), initLss, lssSplices) where + +import Control.Monad (when) +import Data.List (isSuffixOf) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Unique +import Heist (Splices, getParamNode, + hcInterpretedSplices, ( ## )) +import Heist.Interpreted (Splice) +import Prelude hiding ((++)) +import Snap +import Snap.Snaplet.Heist (Heist, addConfig) +import System.Directory +import System.FilePath +import qualified Text.XmlHtml as X + +import Language.Lss + +(++) :: Monoid d => d -> d -> d +(++) = mappend + +data Lss = Lss + +initLss :: Snaplet (Heist b) -> SnapletInit b Lss +initLss heist = makeSnaplet "lss" "" Nothing $ do + dir <- getSnapletFilePath + dirExists <- liftIO $ doesDirectoryExist dir + when (not dirExists) $ liftIO $ createDirectory dir + files <- map (dir ) <$> liftIO (getDirectoryContents dir) + st <- foldM (\s f -> do isF <- liftIO $ doesFileExist f + if not isF || not (".lss" `isSuffixOf` f) + then return s + else do + c <- liftIO $ T.readFile f + case parseDefs c of + Left err -> error $ "Lss: Error parsing file " ++ f ++ ": " ++ err + Right stat -> return $ mappend s stat) + mempty + files + addConfig heist mempty { hcInterpretedSplices = lssSplices st } + return Lss + + +lssSplices :: (MonadIO m, Functor m) => LssState -> Splices (Splice m) +lssSplices st = "lss" ## lssSplice + where lssSplice = + do n <- getParamNode + case X.getAttribute "apply" n of + Nothing -> error "Lss: Can't apply tag without `apply` attribute." + Just a -> + case parseApp a of + Left err -> error $ "Lss: error parsing `apply` attribute: " ++ err + Right (LssApp ident args) -> + do case apply st ident args of + Left err -> error $ "Lss: error applying " ++ (T.unpack $ unIdent ident) + ++ ": " ++ T.unpack err + Right rules -> do + let childs = case X.getAttribute "class" n of + Nothing -> X.elementChildren n + Just cls -> map (addClass cls) (X.elementChildren n) + sym <- (("lss" ++) . show . hashUnique) <$> liftIO newUnique + return $ attach sym rules childs + where addClass newCls n@(X.Element _ attrs _) = + let classAttr = case lookup "class" attrs of + Nothing -> ("class", newCls) + Just cls -> ("class", newCls ++ " " ++ cls) + in n { X.elementAttrs = classAttr : filter ((/= "class").fst) attrs} + addClass _ n = n