module Snap.Snaplet.CSS.Minify
( CssMin
, cssMinInit
, ParseException
) where
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
import qualified Data.ByteString.UTF8 as BS
import Control.Applicative ((<$), (<$>), (<*>))
import Control.Exception (Exception (..), SomeException (..), throw)
import Control.Lens (Lens', (<&>), over, view)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (get, modify)
import Data.List (isSuffixOf)
import Data.Text (Text)
import Data.Typeable (Typeable, cast)
import Snap.Core
import Snap.Snaplet
import System.FilePath ((</>))
import System.Directory (doesFileExist)
import Text.CSS.Parse (NestedBlock, parseNestedBlocks)
import Text.CSS.Render (renderNestedBlocks)
data CssMin = CssMin { _cache :: [(FilePath, Text)] }
cache :: Lens' CssMin [(FilePath, Text)]
cache f m = f (_cache m) <&> \ c -> m { _cache = c }
cssMinInit :: SnapletInit b CssMin
cssMinInit = makeSnaplet "css-min" "CSS minifier" Nothing $
CssMin [] <$ addRoutes [("", serveCss)]
serveCss :: Handler b CssMin ()
serveCss = do
fp <- (</>) <$> getSnapletFilePath <*>
(BS.toString . rqPathInfo <$> getRequest)
liftIO (doesFileExist fp) >>=
flip unless pass . (".css" `isSuffixOf` fp &&)
view cache <$> get >>= maybe (minify fp) writeCss . lookup fp
minify :: FilePath -> Handler b CssMin ()
minify fp = parseNestedBlocks <$>
(getSnapletFilePath >>= liftIO . T.readFile . (</> fp)) >>=
either (throw . ParseException) (cacheAndWrite fp)
cacheAndWrite :: FilePath -> [NestedBlock] -> Handler b CssMin ()
cacheAndWrite fp css = do
let text = LT.toStrict $ LT.toLazyText $ renderNestedBlocks css
modify $ over cache ((fp, text) :)
writeCss text
writeCss :: Text -> Handler b v ()
writeCss css = do
modifyResponse
$ setContentLength (fromIntegral $ T.length css)
. setContentType "text/css"
. setResponseCode 200
writeText css
data ParseException = ParseException String
deriving (Typeable)
instance Show ParseException where
show (ParseException msg) = "CSS parse exception: " ++ msg
instance Exception ParseException where
toException = SomeException
fromException = cast