snap-app (empty) → 0.1.0.0

raw patch · 7 files changed

+312/−0 lines, 7 filesdep +MonadCatchIO-transformersdep +basedep +blaze-htmlsetup-changed

Dependencies added: MonadCatchIO-transformers, base, blaze-html, bytestring, mtl, network, pgsql-simple, safe, snap-core, text, utf8-string

Files

LICENSE +30/−0
Setup.hs +2/−0
snap-app.cabal +26/−0
src/Snap/App.hs +11/−0
src/Snap/App/Controller.hs +107/−0
src/Snap/App/Model.hs +63/−0
src/Snap/App/Types.hs +73/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Chris Done++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 Chris Done 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 view

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

+ snap-app.cabal view

@@ -0,0 +1,26 @@+name:                snap-app+version:             0.1.0.0+synopsis:            Simple modules for writing apps with Snap, abstracted from hpaste.+homepage:            Simple modules for writing apps with Snap, abstracted from hpaste.+license:             BSD3+license-file:        LICENSE+author:              Chris Done+maintainer:          chrisdone@gmail.com+category:            Web+build-type:          Simple+cabal-version:       >=1.8++library+  hs-source-dirs:    src+  exposed-modules:   Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model+  build-depends:     base >= 4 && <5,+                     snap-core,+                     network,+                     pgsql-simple >= 0.1.1,+                     mtl,+                     blaze-html == 0.4.3.4,+                     safe,+                     text,+                     utf8-string,+                     bytestring,+                     MonadCatchIO-transformers

+ src/Snap/App.hs view

@@ -0,0 +1,11 @@+module Snap.App+  (module Snap.Core+  ,module Snap.App.Types+  ,module Snap.App.Controller+  ,module Snap.App.Model)+  where++import Snap.Core+import Snap.App.Types+import Snap.App.Controller+import Snap.App.Model

+ src/Snap/App/Controller.hs view

@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Controller routing/handling.++module Snap.App.Controller+  (runHandler+  ,output+  ,outputText+  ,goHome+  ,justOrGoHome+  ,getInteger+  ,getString+  ,getStringMaybe+  ,getPagination+  ,getMyURI)+  where++import Snap.Core+import Snap.App.Types++import Control.Applicative+import Control.Monad.Env+import Control.Monad.Reader       (runReaderT)+import Data.ByteString            (ByteString)+import Data.ByteString.UTF8       (toString)+import Data.Maybe+import Network.URI+import Data.Text.Lazy             (Text,toStrict)+import Database.PostgreSQL.Base   (withPoolConnection)+import Database.PostgreSQL.Simple (Pool)+import Safe                       (readMay)+import Text.Blaze                 (Html)+import Text.Blaze.Renderer.Text   (renderHtml)++-- | Run a controller handler.+runHandler :: s -> c -> Pool -> Controller c s () -> Snap ()+runHandler st conf pool ctrl = do+  withPoolConnection pool $ \conn -> do+    let state = ControllerState conf conn st+    -- Default to HTML, can be overridden.+    modifyResponse $ setContentType "text/html"+    runReaderT (runController ctrl) state++-- | Strictly renders HTML to Text before outputting it via Snap.+--   This ensures that any lazy exceptions are caught by the Snap+--   handler.+output :: Html -> Controller c s ()+output html = outputText $ renderHtml $ html++-- | Strictly renders text before outputting it via Snap.+--   This ensures that any lazy exceptions are caught by the Snap+--   handler.+outputText :: Text -> Controller c s ()+outputText text = do+  let !x = toStrict $ text+  writeText x++-- | Generic redirect to home page.+goHome :: Controller c s ()+goHome = redirect "/"++-- | Extract a Just value or go home.+justOrGoHome :: Maybe a -> (a -> Controller c s ()) -> Controller c s ()+justOrGoHome x m = maybe goHome m x++-- | Get integer parmater.+getInteger :: ByteString -> Integer -> Controller c s Integer+getInteger name def = do+  pid <- (>>= readMay . toString) <$> getParam name+  maybe (return def) return pid++-- | Get string.+getString :: ByteString -> String -> Controller c s String+getString name def = do+  pid <- (>>= return . toString) <$> getParam name+  maybe (return def) return pid++-- | Get string (maybe).+getStringMaybe :: ByteString -> Controller c s (Maybe String)+getStringMaybe name = do+  pid <- (>>= return . toString) <$> getParam name+  return pid++-- | Get pagination data.+getPagination :: AppConfig c => Controller c s Pagination+getPagination = do+  p <- getInteger "page" 1+  limit <- getInteger "limit" 35+  uri <- getMyURI+  return Pagination { pnPage = max 1 p+                    , pnLimit = max 1 (min 100 limit)+                    , pnURI = uri+                    , pnResults = 0+                    , pnTotal = 0+                    }++getMyURI :: AppConfig c => Controller c s URI+getMyURI = do+  domain <- env (getConfigDomain . controllerStateConfig)+  fmap (fromJust .+	parseURI .+	(("http://" ++ domain) ++) .+	toString .+	rqURI)+       getRequest

+ src/Snap/App/Model.hs view

@@ -0,0 +1,63 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Model running.++module Snap.App.Model+  (model+  ,query+  ,single+  ,singleNoParams+  ,queryNoParams+  ,exec+  ,DB.Only(..))+  where++import           Control.Monad.Env                       (env)++import           Control.Monad.Reader+import           Data.String+import           Database.PostgreSQL.Simple              (Only(..))+import qualified Database.PostgreSQL.Simple              as DB+import           Database.PostgreSQL.Simple.QueryParams+import           Database.PostgreSQL.Simple.QueryResults+import           Snap.App.Types++-- | Run a model action.+model :: AppLiftModel c s => Model c s a -> Controller c s a+model = liftModel++-- | Query with some parameters.+query :: (QueryParams ps,QueryResults r) => [String] -> ps -> Model c s [r]+query q ps = do+  conn <- env modelStateConn+  Model $ ReaderT (\_ -> DB.query conn (fromString (unlines q)) ps)++-- | Query a single field from a single result.+single :: (QueryParams ps,QueryResults (Only r)) => [String] -> ps -> Model c s (Maybe r)+single q ps = do+  rows <- query q ps+  case rows of+    [(Only r)] -> return (Just r)+    _          -> return Nothing++-- | Query a single field from a single result (no params).+singleNoParams :: (QueryResults (Only r)) => [String] -> Model c s (Maybe r)+singleNoParams q = do+  rows <- queryNoParams q+  case rows of+    [(Only r)] -> return (Just r)+    _          -> return Nothing++-- | Query with no parameters.+queryNoParams :: (QueryResults r) => [String] -> Model c s [r]+queryNoParams q = do+  conn <- env modelStateConn+  Model $ ReaderT (\_ -> DB.query_ conn (fromString (unlines q)))++-- | Execute some SQL returning the rows affected.+exec :: (QueryParams ps) => [String] -> ps -> Model c s Integer+exec q ps = do+  conn <- env modelStateConn+  Model $ ReaderT (\_ -> DB.execute conn (fromString (unlines q)) ps)

+ src/Snap/App/Types.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS -Wall #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Model-view-controller app types.++module Snap.App.Types+       (Controller(..)+       ,Model(..)+       ,ControllerState(..)+       ,ModelState(..)+       ,AppConfig(..)+       ,AppLiftModel(..)+       ,Pagination(..))+       where++import Control.Applicative        (Applicative,Alternative)+import Control.Monad              (MonadPlus)+import Control.Monad.Catch        (MonadCatchIO)+import Control.Monad.Reader       (ReaderT,MonadReader)+import Control.Monad.Trans        (MonadIO)+import Database.PostgreSQL.Simple (Connection)+import Network.URI (URI)+import Snap.Core                  (Snap,MonadSnap)++-- | The state accessible to the controller (DB/session stuff).+data ControllerState config state = ControllerState {+    controllerStateConfig :: config+  , controllerStateConn   :: Connection+  , controllerState       :: state+  }++-- | The controller monad.+newtype Controller config state a = Controller {+    runController :: ReaderT (ControllerState config state) Snap a+  } deriving (Monad+             ,Functor+             ,Applicative+             ,Alternative+             ,MonadReader (ControllerState config state)+             ,MonadSnap+             ,MonadIO+             ,MonadPlus+             ,MonadCatchIO)++-- | The state accessible to the model (just DB connection).+data ModelState config state = ModelState {+    modelStateConn   :: Connection+  , modelStateAnns   :: state+  , modelStateConfig :: config+  }++-- | The model monad (limited access to IO, only DB access).+newtype Model config state a = Model {+    runModel :: ReaderT (ModelState config state) IO a+  } deriving (Monad,Functor,Applicative,MonadReader (ModelState config state),MonadIO)++-- | Pagination data.+data Pagination = Pagination {+   pnPage :: Integer+ , pnLimit :: Integer+ , pnURI :: URI+ , pnResults :: Integer+ , pnTotal :: Integer+} deriving Show++class AppConfig config where+  getConfigDomain :: config -> String++class AppLiftModel c s where+  liftModel :: Model c s a -> Controller c s a