packages feed

scotty-fay (empty) → 0.0.1

raw patch · 11 files changed

+443/−0 lines, 11 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, data-default, directory, fay, fay-jquery, http-types, scotty, scotty-fay, test-framework, test-framework-hunit, text, transformers, wai, wai-test

Files

+ LICENSE view
@@ -0,0 +1,25 @@++The MIT License (MIT)++Copyright (c) 2013 Harry Garrood++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+++
+ README.md view
@@ -0,0 +1,12 @@+scotty-fay+==========++A Scotty application which compiles and serves [Fay][] on request.++Todo:++* Production mode. Precompile Fay.++See the example/ directory for example use.++[Fay]: http://fay-lang.org
+ Setup.hs view
@@ -0,0 +1,4 @@+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ example/Main.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+import qualified Data.Text.Lazy as T+import Web.Scotty+import Web.Scotty.Fay++main :: IO ()+main = scotty 3000 $ do+    serveFay $+        -- If the first segment of the request path matches this, try to serve+        -- Fay. Otherwise try the next route.+        under "/scotty-fay" .+        -- Specify the directory where your Fay files are.+        from "src/fay"++    get "/" $ do+        let (+>) = T.append -- just to make it shorter+        html $+            "<!doctype html>" +>+            "<html>" +>+            "<head>" +>+            "<script type=text/javascript src=/scotty-fay/HelloWorld.hs></script>" +>+            "</head>" +>+            "<body><h1>lol</h1></body>" +>+            "</html>"
+ example/src/fay/HelloWorld.hs view
@@ -0,0 +1,11 @@+-- src/fay/HelloWorld.hs+module HelloWorld where++import Prelude+import FFI++alert :: String -> Fay ()+alert = ffi "alert(%1)"++main :: Fay ()+main = alert "hello, world"
+ scotty-fay.cabal view
@@ -0,0 +1,62 @@+name:           scotty-fay+version:        0.0.1+build-type:     Simple+cabal-version:  >= 1.10++category:       Development, Web, Fay+maintainer:     Harry Garrood <harry@garrood.me>+license:        MIT+license-file:   LICENSE+extra-source-files:+    README.md+    example/Main.hs+    example/src/fay/HelloWorld.hs++synopsis:       Fay integration for Scotty.+description:    Fay integration for Scotty. For more information, please see <https://github.com/hdgarrood/scotty-fay>.++source-repository head+  type:         git+  location:     https://github.com/hdgarrood/scotty-fay++library+  hs-source-dirs:       src+  default-language:     Haskell2010+  ghc-options:          -Wall+  default-extensions:   OverloadedStrings, Rank2Types+  exposed-modules:      Web.Scotty.Fay+  other-modules:        Web.Scotty.Fay.Utils,+                        Web.Scotty.Fay.Internal,+                        Web.Scotty.Fay.Config+  build-depends:        base   >= 4.0   && < 5.0,+                        scotty >= 0.6.0 && < 0.7.0,+                        fay    >= 0.18  && < 0.19,+                        fay-jquery,+                        bytestring,+                        data-default,+                        http-types,+                        wai,+                        transformers,+                        text,+                        directory++test-suite scotty-fay-tests+  type:                 exitcode-stdio-1.0+  main-is:              Main.hs+  hs-source-dirs:       test+  default-language:     Haskell2010+  ghc-options:          -Wall+  default-extensions:   OverloadedStrings,+                        Rank2Types+  build-depends:        base,+                        scotty-fay,+                        wai-test,+                        test-framework,+                        test-framework-hunit,+                        HUnit,+                        directory,+                        wai,+                        transformers,+                        http-types,+                        scotty+
+ src/Web/Scotty/Fay.hs view
@@ -0,0 +1,52 @@+module Web.Scotty.Fay+    ( module Web.Scotty.Fay.Config+    , compileFile+    , serveFay+    , serveFay'+    ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Text.Lazy as LT+import Web.Scotty.Trans hiding (file)+import qualified Fay+import System.Directory++import Web.Scotty.Fay.Internal+import Web.Scotty.Fay.Config++data CompileResult = Success String+                   | Error String+                   | FileNotFound String++compileFile :: Config -> FilePath -> IO CompileResult+compileFile conf file = do+    exists <- doesFileExist file+    if not exists+        then return . FileNotFound $+            "scotty-fay: Could not find " ++ file -- TODO: hs relative path?+        else do+            file' <- canonicalizePath file+            res <- Fay.compileFile (toFay conf) file'+            case res of+                Right (out, _) -> return $ Success out+                Left err       -> return . Error . Fay.showCompileError $ err++serveFay :: (MonadIO a, Functor a) => ConfigBuilder -> ScottyT LT.Text a ()+serveFay = serveFay' . buildConfig++serveFay' :: (MonadIO a, Functor a) => Config -> ScottyT LT.Text a ()+serveFay' conf = do+    liftIO $ initialize conf++    get (pattern $ configBasePath conf) $ do+        path <- maybeParam "path"+        case path of+            Just path' -> do+                let filePath = configSrcDir conf ++ "/" ++ path'+                result <- liftIO (compileFile conf filePath)+                case result of+                    Success code     -> respondWithJs code+                    Error err        -> raiseErr err+                    FileNotFound msg -> notFoundMsg msg+            Nothing -> notFoundMsg "scotty-fay: requested path is invalid"+    where
+ src/Web/Scotty/Fay/Config.hs view
@@ -0,0 +1,41 @@+module Web.Scotty.Fay.Config+    ( Config+    , ConfigBuilder+    , configSrcDir+    , configBasePath+    , buildConfig+    , under+    , from+    , toFay+    ) where++import Data.Default+import qualified Data.Text as T+import qualified Fay+import qualified Fay.Compiler.Config as Fay++data Config = Config+    { configBasePath :: T.Text+    , configSrcDir   :: FilePath+    }++instance Default Config where+    def = Config+        { configBasePath = ""+        , configSrcDir   = ""+        }++type ConfigBuilder = Config -> Config++buildConfig :: ConfigBuilder -> Config+buildConfig f = f def++-- Convert a scotty-fay Config to a Fay CompileConfig+toFay :: Config -> Fay.CompileConfig+toFay conf = Fay.addConfigDirectoryIncludePaths [configSrcDir conf] $ def++under :: T.Text -> ConfigBuilder+under basePath conf = conf { configBasePath = basePath }++from :: FilePath -> ConfigBuilder+from dir conf = conf { configSrcDir = dir }
+ src/Web/Scotty/Fay/Internal.hs view
@@ -0,0 +1,89 @@+module Web.Scotty.Fay.Internal where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Web.Scotty.Trans+import Network.Wai+import Network.HTTP.Types (notFound404)+import System.Directory++import Web.Scotty.Fay.Config+import Web.Scotty.Fay.Utils+++-- General dumping ground for helper functions.++warn :: String -> IO ()+warn = putStrLn . ("scotty-fay: " ++)++-- Run once, at application startup. Used for checking that the configuration+-- is sane.+initialize :: Config -> IO ()+initialize conf = do+    let srcDir = configSrcDir conf+    exists <- doesDirectoryExist srcDir+    unless exists $ do+        warn $ "The source directory: " ++ show srcDir +++                " does not exist. Continuing anyway..."++-- The route matcher function, to be given to Scotty. Ensure the request path+-- starts with the given base path, and then put the rest of the path into+-- the "filePath" parameter (if it exists, and is valid).+route :: T.Text -> Request -> Maybe [Param]+route base req = do+    base' <- eatFromStart "/" base+    let pathSegments = pathInfo req+    first <- safeHead pathSegments+    rest  <- nonEmptyTail pathSegments++    guard (first == base')+    return . maybeToList . makeParam $ rest+    where+        safeHead            = listToMaybe++        nonEmptyTail []     = Nothing+        nonEmptyTail [_]    = Nothing+        nonEmptyTail (_:xs) = Just xs++pattern :: T.Text -> RoutePattern+pattern = function . route++eatFromStart :: T.Text -> T.Text -> Maybe T.Text+eatFromStart prefix str =+    if prefix `T.isPrefixOf` str+        then Just $ T.drop (T.length prefix) str+        else Nothing++makeParam :: [T.Text] -> Maybe (LT.Text, LT.Text)+makeParam = fmap (\p -> ("path", LT.fromStrict p)) . secureRejoin++-- Rejoin path segments to get a file path, while preventing directory+-- traversal attacks.+secureRejoin :: [T.Text] -> Maybe T.Text+secureRejoin xs = do+    guard (noDots xs)+    return $ T.intercalate "/" xs+    where+        noDots = not . elem ".."++maybeParam :: (Functor a, MonadIO a, Parsable b) =>+              LT.Text -> ActionT LT.Text a (Maybe b)+maybeParam key = fmap Just (param key) `rescue` (const $ return Nothing)++respondWithJs :: MonadIO a => String -> ActionT LT.Text a ()+respondWithJs jsString = do+    setHeader "Content-Type" "text/javascript"+    raw $ stringToLazyByteString jsString++notFoundMsg :: MonadIO a => String -> ActionT LT.Text a ()+notFoundMsg msg = do+    status notFound404+    text (stringToLazyText msg)++raiseErr :: MonadIO a => String -> ActionT LT.Text a ()+raiseErr = raise . wrapInPreTag . stringToLazyText+    where+        wrapInPreTag str = "<pre>" `LT.append` str `LT.append` "</pre>"
+ src/Web/Scotty/Fay/Utils.hs view
@@ -0,0 +1,17 @@+module Web.Scotty.Fay.Utils where++import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LBC8+import qualified Data.ByteString as B+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LTE+import qualified Data.Text.Encoding as TE++stringToLazyByteString :: String -> LB.ByteString+stringToLazyByteString = LBC8.pack++stringToLazyText :: String -> LT.Text+stringToLazyText = LTE.decodeUtf8 . stringToLazyByteString++strictByteStringToLazyText :: B.ByteString -> LT.Text+strictByteStringToLazyText = LT.fromStrict . TE.decodeUtf8
+ test/Main.hs view
@@ -0,0 +1,106 @@+module Main where++import Control.Monad.IO.Class (liftIO)+import Web.Scotty hiding (request)+import Web.Scotty.Fay+import qualified Network.HTTP.Types as HTTP+import Network.Wai+import Network.Wai.Test+import Test.Framework+import Test.Framework.Providers.HUnit+import qualified Test.HUnit.Base as H+import System.Directory++main :: IO ()+main = do+    dir <- getCurrentDirectory+    putStrLn dir+    tests >>= defaultMain++tests :: IO [Test]+tests = sequence+    [ waiTest "compiles Fay" test_compilesFay+    , waiTest "serveFay captures everything under base" test_capturesEverything+    , waiTest "imports" test_imports+    , waiTest "directory traversal" test_directoryTraversal+    , return $ testGroup "configuration" $+        [ testCase "configuring src dir" test_configuringSrcDir+        , testCase "configuring base path" test_configuringBasePath+        ]+    ]++waiTest :: String -> Session () -> IO Test+waiTest name session = do+    app' <- scottyApp app+    return $ testCase name $ runSession session app'++app :: ScottyM ()+app = do+    serveFay (under "/fay" . from "test/fay-resources")++    get "/" $ do+        text "this is the root"++    get "/fay/shouldnt-get-here" $ do+        text "it shouldn't get here"++-- This is handy to have when debugging interactively.+runScottyApp :: IO ()+runScottyApp = scotty 3000 app++assertBool :: String -> Bool -> Session ()+assertBool str p = liftIO $ H.assertBool str p++assertNotStatus :: Int -> SResponse -> Session ()+assertNotStatus i SResponse{simpleStatus = s} = assertBool (concat+    [ "Expected a status other than "+    , show i+    ]) $ i /= sc+    where+        sc = HTTP.statusCode s++assertJavaScriptRenderedOk :: SResponse -> Session ()+assertJavaScriptRenderedOk response = do+    assertStatus 200 response+    assertHeader "Content-Type" "text/javascript" response++test_compilesFay :: Session ()+test_compilesFay = do+    let req = setPath defaultRequest "/fay/Fact.hs"+    resp <- request req++    assertJavaScriptRenderedOk resp++test_capturesEverything :: Session ()+test_capturesEverything = do+    let req = setPath defaultRequest "/fay/shouldnt-get-here"+    resp <- request req++    assertNotStatus 200 resp++test_imports :: Session ()+test_imports = do+    let req = setPath defaultRequest "/fay/Fib.hs"+    resp <- request req++    assertJavaScriptRenderedOk resp++test_directoryTraversal :: Session ()+test_directoryTraversal = do+    let req = setPath defaultRequest "/fay/test/Fib/../Fib.hs"+    resp <- request req++    assertNotStatus 200 resp++assertEq :: (Eq a, Show a) => a -> a -> H.Assertion+assertEq = H.assertEqual ""++test_configuringSrcDir :: H.Assertion+test_configuringSrcDir =+    assertEq "src" $+        (configSrcDir . buildConfig $ (under "/js" . from "src"))++test_configuringBasePath :: H.Assertion+test_configuringBasePath =+    assertEq "/js" $+        (configBasePath . buildConfig $ (under "/js" . from "src"))