snap-app 0.1.0.0 → 0.1.4

raw patch · 4 files changed

+90/−11 lines, 4 filesdep ~pgsql-simple

Dependency ranges changed: pgsql-simple

Files

snap-app.cabal +3/−3
src/Snap/App/Controller.hs +6/−5
src/Snap/App/Migrate.hs +54/−0
src/Snap/App/Model.hs +27/−3

snap-app.cabal view

@@ -1,5 +1,5 @@ name:                snap-app-version:             0.1.0.0+version:             0.1.4 synopsis:            Simple modules for writing apps with Snap, abstracted from hpaste. homepage:            Simple modules for writing apps with Snap, abstracted from hpaste. license:             BSD3@@ -12,11 +12,11 @@  library   hs-source-dirs:    src-  exposed-modules:   Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model+  exposed-modules:   Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model, Snap.App.Migrate   build-depends:     base >= 4 && <5,                      snap-core,                      network,-                     pgsql-simple >= 0.1.1,+                     pgsql-simple >= 0.1.2,                      mtl,                      blaze-html == 0.4.3.4,                      safe,

src/Snap/App/Controller.hs view

@@ -28,7 +28,7 @@ import Data.Maybe import Network.URI import Data.Text.Lazy             (Text,toStrict)-import Database.PostgreSQL.Base   (withPoolConnection)+import Database.PostgreSQL.Base   (withPoolConnection,withTransaction) import Database.PostgreSQL.Simple (Pool) import Safe                       (readMay) import Text.Blaze                 (Html)@@ -38,10 +38,11 @@ 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+    withTransaction 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

+ src/Snap/App/Migrate.hs view

@@ -0,0 +1,54 @@+-- | Migration library++module Snap.App.Migrate where++import Snap.App.Types+import Snap.App.Model+import Control.Monad+import Control.Monad.Trans+import Database.PostgreSQL.Simple (Only(..))+import GHC.Int++-- | Migrate the DB to the latest version.+migrate :: Bool -> [(Int,Model c s Integer)] -> Model c s ()+migrate create versions = go where+  go = do+    when create $ void $ ensureExists+    rows <- query ["SELECT version FROM version"] ()+    case rows of+      [] -> do echo "No database version, initializing to version 0."+               createVersion+               setVersion 0+      [Only v] -> do+        case lookup (v+1) versions of+          Just doMigrate -> do echo $ "Migrating to version " ++ show (v+1)+                               changes <- doMigrate+                               setVersion (v+1)+                               echo $ "Rows changed: " ++ show changes+                               go+          Nothing -> echo $ "At version " ++ show v ++ "."+      vs -> error $ "There is more than one database version, fix it: " +++                     show vs++-- | Set the current database version.+setVersion :: Int -> Model c s ()+setVersion v = do+  _ <- exec ["UPDATE version SET version = ?"] (Only v)+  echo $ "Version set to " ++ show v ++ "."+  return ()++-- | Ensure the version table exists.+ensureExists :: Model c s ()+ensureExists = do+  _ <- exec ["CREATE TABLE version (version int not null default 0)"] ()+  return ()++-- | Create the version number.+createVersion :: Model c s ()+createVersion = do+  _ <- exec ["INSERT INTO version (version) VALUES (0)"] ()+  echo $ "Version table created."++-- | Just print to stdout for now.+echo :: String -> Model c s ()+echo = liftIO . putStrLn

src/Snap/App/Model.hs view

@@ -6,27 +6,51 @@  module Snap.App.Model   (model+  ,runDB   ,query   ,single   ,singleNoParams   ,queryNoParams+  ,processQuery+  ,queryProcessed   ,exec   ,DB.Only(..))   where  import           Control.Monad.Env                       (env)- import           Control.Monad.Reader import           Data.String-import           Database.PostgreSQL.Simple              (Only(..))+import           Database.PostgreSQL.Base   (withPoolConnection,withTransaction)+import           Database.PostgreSQL.Simple              (Only(..),ProcessedQuery,Query) import qualified Database.PostgreSQL.Simple              as DB+import           Database.PostgreSQL.Simple (Pool) import           Database.PostgreSQL.Simple.QueryParams import           Database.PostgreSQL.Simple.QueryResults import           Snap.App.Types --- | Run a model action.+-- | Run a model action at the top-level.+runDB :: s -> c -> Pool -> Model c s () -> IO ()+runDB st conf pool mdl = do+  withPoolConnection pool $ \conn -> do+    withTransaction conn $ do+      let state = ModelState conn st conf+      -- Default to HTML, can be overridden.+      runReaderT (runModel mdl) state++-- | Run a model action from within a controller. model :: AppLiftModel c s => Model c s a -> Controller c s a model = liftModel++-- | A version of 'query' that does not perform query substitution.+queryProcessed :: (QueryResults r) => ProcessedQuery r -> Model c s [r]+queryProcessed pq = do+  conn <- env modelStateConn+  Model $ ReaderT (\_ -> DB.queryProcessed conn pq)++-- | Process a query for later use.+processQuery :: (QueryParams q,QueryResults r) => Query -> q -> Model c s (ProcessedQuery r)+processQuery template qs = do+  Model $ ReaderT (\_ -> DB.processQuery template qs)  -- | Query with some parameters. query :: (QueryParams ps,QueryResults r) => [String] -> ps -> Model c s [r]