module Snap.Snaplet.Fay (
Fay
, initFay
, fayServe
, fayax
, toFayax
, fromFayax
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Class
import Control.Monad.Trans.Writer
import qualified Data.Aeson as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Configurator as C
import Data.Data
import Data.List
import Data.Maybe
import Data.String
import Language.Fay.Convert
import Snap.Core
import Snap.Snaplet
import Snap.Util.FileServe
import System.Directory
import System.FilePath
import Paths_snaplet_fay
import Snap.Snaplet.Fay.Internal
initFay :: SnapletInit b Fay
initFay = makeSnaplet "fay" description datadir $ do
config <- getSnapletUserConfig
fp <- getSnapletFilePath
(opts, errs) <- runWriterT $ do
compileModeStr <- logErr "Must specify compileMode" $ C.lookup config "compileMode"
compileMode <- case compileModeStr of
Just x -> logErr "Invalid compileMode" . return $ compileModeFromString x
Nothing -> return Nothing
verbose <- logErr "Must specify verbose" $ C.lookup config "verbose"
prettyPrint <- logErr "Must specify prettyPrint" $ C.lookup config "prettyPrint"
includeDirs <- logErr "Must specify includeDirs" $ C.lookup config "includeDirs"
let inc = maybe [] (split ',') includeDirs
inc' <- liftIO $ mapM canonicalizePath inc
return (verbose, compileMode, prettyPrint, inc')
let fay = case opts of
(Just verbose, Just compileMode, Just prettyPrint, includeDirs) ->
Fay fp verbose compileMode prettyPrint (fp : includeDirs)
_ -> error $ intercalate "\n" errs
liftIO $ mapM_ createDirUnlessExists [fp, srcDir fay, destDir fay]
when (Production == compileMode fay) (liftIO $ compileAll fay)
return fay
where
split :: Eq a => a -> [a] -> [[a]]
split _ [] = []
split a as = takeWhile (/= a) as : split a (drop 1 $ dropWhile (/= a) as)
createDirUnlessExists fp = do
dirExists <- doesDirectoryExist fp
unless dirExists $ createDirectory fp
datadir = Just $ liftM (++ "/resources") getDataDir
description = "Automatic (re)compilation and serving of Fay files"
logErr :: MonadIO m => t -> IO (Maybe a) -> WriterT [t] m (Maybe a)
logErr err m = do
res <- liftIO m
when (isNothing res) (tell [err])
return res
compileModeFromString :: String -> Maybe CompileMode
compileModeFromString "Development" = Just Development
compileModeFromString "Production" = Just Production
compileModeFromString _ = Nothing
fayServe :: Handler b Fay ()
fayServe = do
modifyResponse . setContentType $ "text/javascript;charset=utf-8"
get >>= compileWithMode . compileMode
fayax :: (Data f1, Read f1, Show f2) => (f1 -> Handler h1 h2 f2) -> Handler h1 h2 ()
fayax g = do
res <- decode
case res of
Left body -> send500 $ Just body
Right res -> toFayax . g $ res
toFayax :: Show f2 => Handler h1 h2 f2 -> Handler h1 h2 ()
toFayax g = do
modifyResponse . setContentType $ "text/json;charset=utf-8"
writeLBS . A.encode . showToFay =<< g
fromFayax :: (Data f1, Read f1) => (f1 -> Handler h1 h2 ()) -> Handler h1 h2 ()
fromFayax g = do
res <- decode
case res of
Left body -> send500 $ Just body
Right res -> g res
decode :: (Data f1, Read f1) => Handler h1 h2 (Either ByteString f1)
decode = do
body <- readRequestBody 1024
res <- return $ A.decode body >>= readFromFay
return $ case res of
Nothing -> Left. BS.concat . BL.toChunks $ "Could not decode " `BL.append` body
Just x -> Right x
compileWithMode :: CompileMode -> Handler b Fay ()
compileWithMode Development = do
cfg <- get
uri <- (srcDir cfg </>) . toHsName . filename . BS.unpack . rqURI <$> getRequest
res <- liftIO (compileFile cfg uri)
case res of
Success s -> writeBS $ fromString s
NotFound -> send404 Nothing
Error err -> send500 . Just . BS.pack $ err
compileWithMode Production = get >>= serveDirectory . destDir
send404 :: Maybe ByteString -> Handler a b ()
send404 msg = do
modifyResponse $ setResponseStatus 404 "Not Found"
writeBS $ fromMaybe "Not Found" msg
finishWith =<< getResponse
send500 :: Maybe ByteString -> Handler a b ()
send500 msg = do
modifyResponse $ setResponseStatus 500 "Internal Server Error"
writeBS $ fromMaybe "Internal Server Error" msg
finishWith =<< getResponse