snaplet-ghcjs (empty) → 0.1.0.0

raw patch · 4 files changed

+274/−0 lines, 4 filesdep +basedep +directorydep +filepathsetup-changed

Dependencies added: base, directory, filepath, lens, mtl, process, snap, snap-core, string-conversions, transformers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• Snap/Snaplet/GHCJS.hs +205/−0
• snaplet-ghcjs.cabal +37/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, Sönke Hahn++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 Sönke Hahn 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,205 @@+{-# language OverloadedStrings #-}+{-# language TemplateHaskell #-}++-- | Snaplet that serves javascript files compiled with ghcjs +--   (<https://github.com/valderman/ghcjs-compiler>). This Snaplet is meant to be+--   used for development. You can work on client side Haskell code and+--   immedietely test the code with a simple browser reload. It certainly adds+--   some overhead and is not meant to be used in production websites.+--+-- Usage:+--+-- Put haskell source files in the snaplet path (e.g. @$ROOT\/snaplets\/ghcjs@).+-- For every such haskell file there will be a new javascript file available via+-- http.+--+-- * Other files won't be served through http. The snaplet will 'mzero' on .hs,+--   .hi, .o and all other files.+--+-- * If any haskell file in the snaplet path is newer than the+--   requested javascript file, it will be recompiled.  The ghcjs+--   snaplet does not track haskell import dependencies: recompilation+--   happens whether the js file is requested or not.+--+-- * If ghcjsc exits with an error code this snaplet will serve a special+--   javascript file that contains the error message as a comment and a+--   javascript command that will raise the error message as a javascript+--   exception.+-- +-- Please add such a handler to your routes:+--+--   [ ...+--   , ("" , with ghcjs ghcjsServe)+--   ]++module Snap.Snaplet.GHCJS (+    GHCJS,+    snapletArgs,+    initialize,+    ghcjsServe,+  ) where+++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.State.Class as State+import Control.Lens (makeLenses)+import Data.List+import Data.String.Conversions+import Snap.Core+import Snap.Snaplet+import Snap.Util.FileServe+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.Process+import Text.Printf++++-- | Internal data type for the ghcjs snaplet.+data GHCJS = GHCJS { _ghcjsc :: FilePath+                   , _snapletArgs :: [String]+                   }++makeLenses ''GHCJS++-- | Initializes the ghcjs snaplet. Use it with e.g. 'nestSnaplet'.+initialize :: [String] -> SnapletInit app GHCJS+initialize args = makeSnaplet "ghcjs" description Nothing $ do+    cabalPackageDBs <- liftIO parseCabalPackageDBs+    let packageArgs = cabalPackageDBs >>= (\a -> ["-package-db", a])+    liftIO $ mapM_ putStrLn packageArgs+    return $ GHCJS "ghcjs" (packageArgs ++ args)+  where+    description = "handler for delivering javascript files compiled with ghcjs"++-- The following is a hack. There is code to parse the cabal config properly+-- to find the sandbox, but it is in cabal-install which doesn't export it++-- There may also be a few ways of doing this with cabal, but they would+-- be even worse than the following:+parseCabalPackageDBs :: IO [String]+parseCabalPackageDBs = do+    -- lines not indented are paths+    -- TODO - validate properly+    let isPath s = take 2 s /= ("  "::String) && take 1 s == ("/" :: String)++    dir <- getCurrentDirectory++    writeFile "cabal.snaplet-ghcjs.config" $+      unlines [ "-- Automatically generated by snaplet-ghcjs to help determine location of package db, working around https://github.com/haskell/cabal/pull/2859"+              , "compiler: ghcjs"+              , "-- Thankyou."+              , ""]++    (_stdin, Just stdoutH, Just stderrH, processHandle) <-+        createProcess (proc "cabal" ["--config-file=cabal.snaplet-ghcjs.config", "exec", "ghcjs-pkg", "list"]){+            cwd = Just dir,+            std_out = CreatePipe,+            std_err = CreatePipe+          }+    exitCode <- waitForProcess processHandle+    stdout <- hGetContents stdoutH+    stderr <- hGetContents stderrH+    case exitCode of+      -- Delete trailing colon+      ExitSuccess -> return $ map init $ filter isPath $ lines stdout+      ExitFailure _ -> do+        putStrLn "snaplet-ghcjs WARNING: dirty hack failed. Please set -package-db yourself."+        return []+++ghcjsServe :: Handler app GHCJS ()+ghcjsServe = do+    jsPath <- cs <$> rqPathInfo <$> getRequest+    ghcjsDir <- getSnapletFilePath+    if takeExtension jsPath /= ".js" then+        mzero+      else+        deliverJS (dropExtension (ghcjsDir </> jsPath))++deliverJS :: FilePath -> Handler app GHCJS ()+deliverJS basename = do+    hsExists   <- liftIO $ doesFileExist (basename <.> "hs")++    unless hsExists mzero++    let jsFile =  jsFileName basename+    snapletDir <- getSnapletFilePath++    jsNewer    <- liftIO $ isJSNewer jsFile snapletDir++    if jsNewer then+            serveFile jsFile+          else+            compile basename++-- | Returns whether the given javascript file exists and is newer than+--   all Haskell files in the given directory.+isJSNewer :: FilePath -> FilePath -> IO Bool+isJSNewer jsFile dir = do+    exists <- liftIO $ doesFileExist jsFile+    if not exists then+        return False+      else do+        hsFiles <- collectAllHsFiles dir+        hsTimeStamps <- mapM getModificationTime hsFiles+        jsTimeStamp <- getModificationTime jsFile+        return (jsTimeStamp > maximum hsTimeStamps)+  where+    collectAllHsFiles :: FilePath -> IO [FilePath]+    collectAllHsFiles dir = do+        paths <- fmap (dir </>) <$>+            filter (not . ("." `isPrefixOf`)) <$>+            getDirectoryContents dir+        (files, dirs) <- partitionM doesFileExist paths+        let hsFiles = filter (\ f -> takeExtension f == ".hs") files+        subHsFiles <- concat <$> mapM collectAllHsFiles dirs+        return (hsFiles ++ subHsFiles)++    partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+    partitionM pred (a : r) = do+        is <- pred a+        (yes, no) <- partitionM pred r+        return $ if is then (a : yes, no) else (yes, a : no)+    partitionM pred [] = return ([], [])++-- | Recompiles the file and serves it in case of success.+compile :: FilePath -> Handler app GHCJS ()+compile name = do+    GHCJS+      ghcjsc+      snapletArgs       <- State.get+    let args            =  snapletArgs ++ [name <.> "hs"]+        outfile         =  jsFileName name+    dir                 <- getSnapletFilePath++    (exitCode, message) <- liftIO $ do+        (_stdin, Just stdoutH, Just stderrH, processHandle) <-+            createProcess (proc ghcjsc args){+                cwd = Just dir,+                std_out = CreatePipe,+                std_err = CreatePipe+              }++        exitCode <- waitForProcess processHandle+        stdout   <- hGetContents stdoutH+        stderr   <- hGetContents stderrH++        return (exitCode, "\nGHCJS error:\n============\n" ++ stdout ++ stderr)++    case exitCode of+        ExitFailure _ ->+            writeBS $ cs (printf ("/*\n\n%s\n\n*/\n\nthrow %s;") message (show message) :: String)++        ExitSuccess -> serveFile outfile++-- At time of writing, there's no way to include js from packages.+-- Just throw everything up onto the frontend without worrying about+-- duplicate code etc.+jsFileName :: String -> FilePath+jsFileName name = name <.> "jsexe" </> "all.js"+

@@ -0,0 +1,37 @@+-- Initial snaplet-haste.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                snaplet-ghcjs+version:             0.1.0.0+synopsis:            Serve javascript files compiled with GHCJS+description:         Dynamically compile Haskell with GHCJS and serve it as JavaScript. +license:             BSD3+license-file:        LICENSE+author:              Sönke Hahn, John Cant+maintainer:          a.johncant@gmail.com+-- copyright:           +category:            Web+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++source-repository head+  type: git+  location: git://github.com/johncant/snaplet-ghcjs.git++library+  exposed-modules:     Snap.Snaplet.GHCJS+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.6 && < 5.0,+                       transformers >=0.3,+                       mtl >=2.1,+                       string-conversions >=0.3,+                       snap-core >=0.9,+                       snap >=0.13,+                       directory >=1.2,+                       filepath >=1.3,+                       process >=1.1,+                       lens >= 0.1+  -- hs-source-dirs:      +  default-language:    Haskell2010