Permalink
Browse files

Initial commit

  • Loading branch information...
0 parents commit 281c5bdb1315eaf270f104578b157feb1a251b3b @ozataman committed Mar 4, 2012
4 .ghci
@@ -0,0 +1,4 @@
+:set -isrc
+:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd
+:set -XOverloadedStrings
@@ -0,0 +1 @@
+dist
30 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.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,4 @@
+<div class='alert alert-${type}' data-alert='alert'>
+ <a class="close" href="#">×</a>
+ <message/>
+</div>
@@ -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:
+
@@ -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
+-------------------------------------------------------------------------------
@@ -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
+
@@ -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: <flash type='warning'/>
+-- Ex: <flash type='success'/>
+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') ]
+
@@ -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
@@ -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:
+--
+-- <rqparam name="username"/>
+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
+
@@ -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

0 comments on commit 281c5bd

Please sign in to comment.