.
+
+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
+
diff --git a/src/Web/Scotty/Fay.hs b/src/Web/Scotty/Fay.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Scotty/Fay.hs
@@ -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
diff --git a/src/Web/Scotty/Fay/Config.hs b/src/Web/Scotty/Fay/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Scotty/Fay/Config.hs
@@ -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 }
diff --git a/src/Web/Scotty/Fay/Internal.hs b/src/Web/Scotty/Fay/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Scotty/Fay/Internal.hs
@@ -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 = "" `LT.append` str `LT.append` "
"
diff --git a/src/Web/Scotty/Fay/Utils.hs b/src/Web/Scotty/Fay/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Scotty/Fay/Utils.hs
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -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"))