diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..a882c32 --- /dev/null +++ b/.ghci @@ -0,0 +1,4 @@ +:set -isrc +:set -hide-package MonadCatchIO-mtl +:set -hide-package monads-fd +:set -XOverloadedStrings diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1521c8b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d810f16 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Ozgun Ataman + +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 Ozgun Ataman 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/resources/templates/_flash.tpl b/resources/templates/_flash.tpl new file mode 100644 index 0000000..9a565d6 --- /dev/null +++ b/resources/templates/_flash.tpl @@ -0,0 +1,4 @@ +
+ × + +
diff --git a/snap-extras.cabal b/snap-extras.cabal new file mode 100644 index 0000000..d5fb8ca --- /dev/null +++ b/snap-extras.cabal @@ -0,0 +1,37 @@ +Name: snap-extras +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Ozgun Ataman +Maintainer: ozataman@gmail.com +Category: Web +Build-type: Simple +Cabal-version: >=1.2 + + +Library + -- Modules exported by the library. + Exposed-modules: + Snap.Extras + Snap.Extras.CoreUtils + Snap.Extras.TextUtils + Snap.Extras.JSON + Snap.Extras.FlashNotice + Snap.Extras.SpliceUtils + + hs-source-dirs: src + Build-depends: + base + , aeson >= 0.6 + , snap-core >= 0.7 + , snap >= 0.7 + , heist >= 0.8 + , xmlhtml >= 0.1.6 + , bytestring + , text + , safe + , data-lens >= 2.0 + , transformers + + -- Other-modules: + \ No newline at end of file diff --git a/src/Snap/Extras.hs b/src/Snap/Extras.hs new file mode 100644 index 0000000..662042a --- /dev/null +++ b/src/Snap/Extras.hs @@ -0,0 +1,15 @@ +module Snap.Extras + ( module Snap.Extras.CoreUtils + , module Snap.Extras.TextUtils + , module Snap.Extras.JSON + , module Snap.Extras.FlashNotice + , module Snap.Extras.SpliceUtils + ) where + +------------------------------------------------------------------------------- +import Snap.Extras.CoreUtils +import Snap.Extras.TextUtils +import Snap.Extras.JSON +import Snap.Extras.FlashNotice +import Snap.Extras.SpliceUtils +------------------------------------------------------------------------------- diff --git a/src/Snap/Extras/CoreUtils.hs b/src/Snap/Extras/CoreUtils.hs new file mode 100644 index 0000000..8a65e2a --- /dev/null +++ b/src/Snap/Extras/CoreUtils.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Snap.Extras.CoreUtils + ( finishEarly + , badReq + , notFound + , serverError + , plainResponse + , jsonResponse + , jsResponse + , easyLog + , getParam' + , reqParam + ) where + +------------------------------------------------------------------------------- +import Snap.Core +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Control.Monad +------------------------------------------------------------------------------- + + + +------------------------------------------------------------------------------- +-- | Discard anything after this and return given status code to HTTP +-- client immediately. +finishEarly :: MonadSnap m => Int -> ByteString -> m b +finishEarly code str = do + modifyResponse $ setResponseStatus code str + modifyResponse $ addHeader "Content-Type" "text/plain" + writeBS str + getResponse >>= finishWith + + +------------------------------------------------------------------------------- +-- | Finish early with error code 400 +badReq :: MonadSnap m => ByteString -> m b +badReq = finishEarly 400 + +------------------------------------------------------------------------------- +-- | Finish early with error code 404 +notFound :: MonadSnap m => ByteString -> m b +notFound = finishEarly 404 + +------------------------------------------------------------------------------- +-- | Finish early with error code 500 +serverError :: MonadSnap m => ByteString -> m b +serverError = finishEarly 500 + + +------------------------------------------------------------------------------- +plainResponse :: MonadSnap m => m () +plainResponse = modifyResponse $ setHeader "Content-Type" "text/plain" + + +------------------------------------------------------------------------------- +jsonResponse :: MonadSnap m => m () +jsonResponse = modifyResponse $ setHeader "Content-Type" "application/json" + + +------------------------------------------------------------------------------- +jsResponse :: MonadSnap m => m () +jsResponse = modifyResponse $ setHeader "Content-Type" "application/javascript" + + +------------------------------------------------------------------------------ +-- | Easy Error log logger +easyLog :: (Show t, MonadSnap m) => String -> t -> m () +easyLog k v = logError . B.pack $ ("[Debug] " ++ k ++ ": " ++ show v) + + +------------------------------------------------------------------------------- +-- | Alternate version of getParam that considers empty string Nothing +getParam' :: MonadSnap m => ByteString -> m (Maybe ByteString) +getParam' = return . maybe Nothing f <=< getParam + where f "" = Nothing + f x = Just x + + +------------------------------------------------------------------------------- +-- | Require that a parameter is present or terminate early. +reqParam :: (MonadSnap m) => ByteString -> m ByteString +reqParam s = do + p <- getParam s + maybe (badReq $ B.concat ["Required parameter ", s, " is missing."]) return p + diff --git a/src/Snap/Extras/FlashNotice.hs b/src/Snap/Extras/FlashNotice.hs new file mode 100644 index 0000000..1ba05b0 --- /dev/null +++ b/src/Snap/Extras/FlashNotice.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Snap.Extras.FlashNotice + ( initFlashNotice + , flashInfo + , flashWarning + , flashSuccess + , flashError + , flashSplice + ) where + +------------------------------------------------------------------------------- +import Control.Monad +import Data.Lens.Common +import Data.Text (Text) +import qualified Data.Text as T +import Snap.Snaplet +import Snap.Snaplet.Heist +import Snap.Snaplet.Session +import Text.Templating.Heist +import Text.XmlHtml +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | Initialize the flash notice system. All you have to do now is to +-- add some flash tags in your application template. See 'flashSplice' +-- for examples. +initFlashNotice + :: HasHeist b + => Lens v (Snaplet SessionManager) -> Initializer b v () +initFlashNotice session = do + addTemplates "resources/templates" + addSplices [("flash", flashSplice session)] + + +------------------------------------------------------------------------------- +-- | Display an info message on next load of a page +flashInfo :: Lens b (Snaplet SessionManager) -> Text -> Handler b b () +flashInfo session msg = withSession session $ with session $ setInSession "_info" msg + + +------------------------------------------------------------------------------- +-- | Display an warning message on next load of a page +flashWarning :: Lens b (Snaplet SessionManager) -> Text -> Handler b b () +flashWarning session msg = withSession session $ with session $ setInSession "_warning" msg + + +------------------------------------------------------------------------------- +-- | Display a success message on next load of a page +flashSuccess :: Lens b (Snaplet SessionManager) -> Text -> Handler b b () +flashSuccess session msg = withSession session $ with session $ setInSession "_success" msg + + +------------------------------------------------------------------------------- +-- | Display an error message on next load of a page +flashError :: Lens b (Snaplet SessionManager) -> Text -> Handler b b () +flashError session msg = withSession session $ with session $ setInSession "_error" msg + + +------------------------------------------------------------------------------- +-- | A splice for rendering a given flash notice dirctive. +-- +-- Ex: +-- Ex: +flashSplice :: Lens v (Snaplet SessionManager) -> SnapletSplice b v +flashSplice session = do + typ <- liftHeist $ liftM (getAttribute "type") getParamNode + let typ' = maybe "warning" id typ + let k = T.concat ["_", typ'] + msg <- liftHandler $ with session $ getFromSession k + case msg of + Nothing -> liftHeist $ return [] + Just msg' -> do + liftHandler $ with session $ deleteFromSession k >> commitSession + liftHeist $ callTemplateWithText "_flash" + [ ("type", typ') , ("message", msg') ] + \ No newline at end of file diff --git a/src/Snap/Extras/JSON.hs b/src/Snap/Extras/JSON.hs new file mode 100644 index 0000000..ba9f328 --- /dev/null +++ b/src/Snap/Extras/JSON.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Extras.JSON + ( reqJSON + ) where + + +------------------------------------------------------------------------------- +import Data.Aeson as A +import qualified Data.ByteString.Char8 as B +import Snap.Core +------------------------------------------------------------------------------- +import Snap.Extras.CoreUtils +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | Demand the presence of JSON in the body. Terminate request early +-- if not found or unparseable. +reqJSON :: (MonadSnap m, A.FromJSON b) => m b +reqJSON = do + bodyVal <- A.decode `fmap` readRequestBody 20000 + case bodyVal of + Nothing -> badReq "Can't find JSON data in POST body" + Just v -> case A.fromJSON v of + A.Error e -> badReq $ B.concat ["Can't parse JSON: ", B.pack e] + A.Success a -> return a diff --git a/src/Snap/Extras/SpliceUtils.hs b/src/Snap/Extras/SpliceUtils.hs new file mode 100644 index 0000000..ad1f757 --- /dev/null +++ b/src/Snap/Extras/SpliceUtils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Snap.Extras.SpliceUtils + ( ifSplice + , paramSplice + , utilSplices + , addUtilSplices + ) where + +------------------------------------------------------------------------------- +import Control.Monad +import Control.Monad.Trans.Class +import Data.Text (Text) +import qualified Data.Text.Encoding as T +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Heist +import Text.Templating.Heist +import Text.XmlHtml +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | Bind splices offered in this module in your 'Initializer' +addUtilSplices :: HasHeist b => Initializer b v () +addUtilSplices = addSplices utilSplices + + +------------------------------------------------------------------------------- +-- | A list of splices offered in this module +utilSplices :: [(Text, SnapletSplice b v)] +utilSplices = + [("rqparam", liftHeist paramSplice)] + + +------------------------------------------------------------------------------- +-- | Run the splice contents if given condition is True, make splice +-- disappear if not. +ifSplice :: Monad m => Bool -> Splice m +ifSplice cond = + case cond of + False -> return [] + True -> runChildren + +------------------------------------------------------------------------------ +-- | Gets the value of a request parameter. Example use: +-- +-- +paramSplice :: MonadSnap m => Splice m +paramSplice = do + at <- liftM (getAttribute "name") getParamNode + val <- case at of + Just at' -> lift . getParam $ T.encodeUtf8 at' + Nothing -> return Nothing + return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val + diff --git a/src/Snap/Extras/TextUtils.hs b/src/Snap/Extras/TextUtils.hs new file mode 100644 index 0000000..01ee4a0 --- /dev/null +++ b/src/Snap/Extras/TextUtils.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Snap.Extras.TextUtils + ( readT + , showT + , readBS + , showBS + ) where + +------------------------------------------------------------------------------- +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Char8 +import qualified Data.Text as T +import Data.Text +import Safe +------------------------------------------------------------------------------- + + +showT :: (Show a) => a -> Text +showT = T.pack . show + + +showBS :: (Show a) => a -> ByteString +showBS = B.pack . show + + +readT :: (Read a) => Text -> a +readT = readNote "Can't read value in readT" . T.unpack + + + +readBS :: (Read a) => ByteString -> a +readBS = readNote "Can't read value in readBS" . B.unpack + +maybeEither (Left e) = Nothing +maybeEither (Right x) = Just x \ No newline at end of file