Initial commit

.ghci

@@ -0,0 +1,4 @@
+:set -isrc
+:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd
+:set -XOverloadedStrings

.gitignore

@@ -0,0 +1 @@
+dist

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.

Setup.hs

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

resources/templates/_flash.tpl

@@ -0,0 +1,4 @@
+<div class='alert alert-${type}' data-alert='alert'>
+  <a class="close" href="#">×</a>
+  <message/> 
+</div>

snap-extras.cabal

@@ -0,0 +1,37 @@
+Name:                snap-extras
+Version:             0.1
+License:             BSD3
+License-file:        LICENSE
+Author:              Ozgun Ataman
+Maintainer:          [email protected]
+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:       
+

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
+-------------------------------------------------------------------------------

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
+

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: <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') ]
+

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

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:
+--
+-- <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
+

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