Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Added example project.

  • Loading branch information...
commit 51f057aa8415789acdaec183bab2529efa4555de 1 parent 810143d
Petr Pilař authored
150 README.md
Source Rendered
@@ -11,153 +11,9 @@ The package itself is divided into two parts:
11 11 1. `Snap.Snaplet.MongoDB.Functions.S`
12 12 2. `Snap.Snaplet.MongoDB.Functions.M`
13 13
14   -## Core
15   -
16   -The `Snap.Snaplet.MongoDB.Core` package contains:
17   - * The Snaplet's data type (`MongoDB`).
18   - * The type class (`HasMongoDB`).
19   - * The initializer (`mongoDBInit`).
20   -
21   -The `MongoDB` data type instances hold connection pool and database name.
22   -
23   -The `HasMongoDB` type class is to be used when you inted to have only one database in your application, more on this later.
24   -
25   -## Functions
26   -
27   -As I have already said,
28   -
29   -The `Functions` package contains the basic functions (initializers and functions for querying the database).
  14 +For details check-out the [documentation](http://palmik.github.com/snaplet-mongodb-minimalistic/)
  15 +(alternatively on [hackage](http://hackage.haskell.org/package/snaplet-mongodb-minimalistic) -- not neccessary up to date).
30 16
31 17 # Examples
32 18
33   -## Example #1
34   -
35   -We will follow the common Snap project structure.
36   -
37   -### src/Application.hs
38   -
39   - {-# LANGUAGE TemplateHaskell #-}
40   - {-# LANGUAGE MultiParamTypeClasses #-}
41   - {-# LANGUAGE TypeSynonymInstances #-}
42   -
43   - module Application where
44   -
45   - import Data.Lens.Template
46   - import Data.Lens.Common
47   -
48   - import Snap.Snaplet
49   - import Snap.Snaplet.Heist
50   - import Snap.Snaplet.MongoDB.Core
51   -
52   - -- We want (.) from Control.Category.
53   - import Control.Category ((.))
54   - import Prelude hiding ((.))
55   -
56   - data App = App
57   - { _heist :: Snaplet (Heist App)
58   - , _database :: Snaplet MongoDB
59   - }
60   -
61   - type AppHandler = Handler App App
62   -
63   - makeLens ''App
64   -
65   - instance HasHeist App where
66   - heistLens = subSnaplet heist
67   -
68   - instance HasMongoDB App where
69   - getMongoDB = getL (snapletValue . database)
70   -
71   -### src/Example/Foo.hs
72   -
73   - {-# LANGUAGE OverloadedStrings #-}
74   - {-# LANGUAGE ExtendedDefaultRules #-}
75   - {-# LANGUAGE NoMonomorphismRestriction #-}
76   -
77   - module Example.Foo
78   - ( makeTeamDocument
79   - , documentsSplice
80   - , module Database.MongoDB
81   - ) where
82   -
83   - import qualified Data.Text as T
84   - import Data.Text (Text)
85   - import qualified Data.Text.Encoding as T (decodeUtf8)
86   -
87   - import Snap
88   - import Snap.Snaplet
89   - import Snap.Snaplet.MongoDB
90   -
91   - import Text.Templating.Heist
92   -
93   - import Database.MongoDB
94   - import Control.Monad.Trans (liftIO)
95   -
96   - makeTeamDocument name city = ["name" =: name, "city" =: city]
97   -
98   - documentsSplice :: (HasMongoDB m) => Collection -> Splice (Handler m m)
99   - documentsSplice collection = do
100   - eres <- eitherWithDB $ rest =<< find (select [] collection)
101   - res <- return $ either (const []) id eres
102   - mapSplices (runChildrenWithText . showAs "document") res
103   -
104   - showAs :: (Show a) => Text -> a -> [(Text, Text)]
105   - showAs name x = [(name, T.pack $ show x)]
106   -
107   -### src/Site.hs
108   -
109   - {-# LANGUAGE OverloadedStrings #-}
110   -
111   - module Site
112   - ( app
113   - ) where
114   -
115   - import Data.ByteString (ByteString)
116   - import Data.ByteString.UTF8 (toString)
117   -
118   - import Snap.Core
119   - import Snap.Util.FileServe
120   -
121   - import Snap.Snaplet
122   - import Snap.Snaplet.Heist
123   - import Snap.Snaplet.MongoDB
124   -
125   - import Text.Templating.Heist
126   - import Text.XmlHtml hiding (render)
127   -
128   - import Application
129   - import Example.Foo
130   -
131   - indexView :: Handler App App ()
132   - indexView = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"
133   - where
134   - indexSplices =
135   - [ ("documents", documentsSplice "test-collection")
136   - ]
137   -
138   - indexHandler :: Handler App App ()
139   - indexHandler = insertTeamHandler >> redirect "/"
140   -
141   - insertTeamHandler :: Handler App App ()
142   - insertTeamHandler = do
143   - name <- getParamOr "form1-name" (redirect "/")
144   - city <- getParamOr "form1-city" (redirect "/")
145   - eitherWithDB $ insert "test-collection" $ makeTeamDocument name city
146   - return ()
147   - where getParamOr param action = getParam param >>= maybe action (return . toString)
148   -
149   - routes :: [(ByteString, Handler App App ())]
150   - routes = [ ("/", method POST indexHandler)
151   - , ("/", indexView)
152   - , ("", with heist heistServe)
153   - , ("", serveDirectory "resources/static")
154   - ]
155   -
156   - app :: SnapletInit App App
157   - app = makeSnaplet "app" "An snaplet example application." Nothing $ do
158   - h <- nestSnaplet "heist" heist $ heistInit "resources/templates"
159   - d <- nestSnaplet "database" database $ mongoDBInit 10 (host "127.0.0.1") "Snaplet-MongoDB"
160   - addRoutes routes
161   - return $ App h d
162   -
163   -And that's it.
  19 +Check out the examples subdirectory.
27 examples/example1/LICENSE
... ... @@ -0,0 +1,27 @@
  1 +Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)
  2 +All rights reserved.
  3 +
  4 +Redistribution and use in source and binary forms, with or without
  5 +modification, are permitted provided that the following conditions are met:
  6 +
  7 +Redistributions of source code must retain the above copyright notice, this
  8 +list of conditions and the following disclaimer.
  9 +
  10 +Redistributions in binary form must reproduce the above copyright notice, this
  11 +list of conditions and the following disclaimer in the documentation and/or
  12 +other materials provided with the distribution.
  13 +
  14 +Neither the name of the Snap Framework authors nor the names of its
  15 +contributors may be used to endorse or promote products derived from this
  16 +software without specific prior written permission.
  17 +
  18 +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
  19 +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  21 +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
  22 +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  24 +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  25 +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  26 +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27 +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
54 examples/example1/example1.cabal
... ... @@ -0,0 +1,54 @@
  1 +name: snaplet-mongodb-minimalistic-example1
  2 +version: 0.0.1
  3 +synopsis: Simple Example.
  4 +description: Simple Example.
  5 +license: BSD3
  6 +license-file: LICENSE
  7 +author: Petr Pilař
  8 +maintainer: jondoe@example.com
  9 +build-type: Simple
  10 +cabal-version: >= 1.6
  11 +homepage: example.com
  12 +category: Web
  13 +
  14 +Flag development
  15 + Description: Whether to build the server in development (interpreted) mode
  16 + Default: False
  17 +
  18 +Executable snaplet-mongodb-minimalistic-example1
  19 + hs-source-dirs: src
  20 + main-is: Main.hs
  21 +
  22 + Build-depends:
  23 + base >= 4 && < 5,
  24 + bytestring >= 0.9.1 && < 0.10,
  25 + data-lens >= 2.0.1 && < 2.1,
  26 + data-lens-template >= 2.1 && < 2.2,
  27 + heist >= 0.7 && < 0.8,
  28 + mtl >= 2 && < 3,
  29 + snap == 0.7.*,
  30 + snap-core == 0.7.*,
  31 + snap-server == 0.7.*,
  32 + text >= 0.11 && < 0.12,
  33 + xmlhtml == 0.1.*,
  34 + snaplet-mongodb-minimalistic,
  35 + mongoDB,
  36 + utf8-string
  37 +
  38 + if flag(development)
  39 + cpp-options: -DDEVELOPMENT
  40 + -- In development mode, speed is already going to suffer, so skip
  41 + -- the fancy optimization flags. Additionally, disable all
  42 + -- warnings. The hint library doesn't give an option to execute
  43 + -- compiled code when there were also warnings, so disabling
  44 + -- warnings allows quicker workflow.
  45 + ghc-options: -threaded -w
  46 + else
  47 + if impl(ghc >= 6.12.0)
  48 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
  49 + -fno-warn-orphans -fno-warn-unused-do-bind
  50 + else
  51 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
  52 + -fno-warn-orphans
  53 +
  54 +
0  examples/example1/log/access.log
No changes.
0  examples/example1/log/error.log
No changes.
26 examples/example1/resources/static/screen.css
... ... @@ -0,0 +1,26 @@
  1 +html {
  2 + padding: 0;
  3 + margin: 0;
  4 + background-color: #ffffff;
  5 + font-family: Verdana, Helvetica, sans-serif;
  6 +}
  7 +body {
  8 + padding: 0;
  9 + margin: 0;
  10 +}
  11 +a {
  12 + text-decoration: underline;
  13 +}
  14 +a :hover {
  15 + cursor: pointer;
  16 + text-decoration: underline;
  17 +}
  18 +img {
  19 + border: none;
  20 +}
  21 +#content {
  22 + padding-left: 1em;
  23 +}
  24 +#info {
  25 + font-size: 60%;
  26 +}
19 examples/example1/resources/templates/index.tpl
... ... @@ -0,0 +1,19 @@
  1 +<html>
  2 + <head>
  3 + <title>Snap web server</title>
  4 + <link rel="stylesheet" type="text/css" href="/screen.css"/>
  5 + </head>
  6 + <body>
  7 + <form method="post">
  8 + <input type="text" name="form1-name" />
  9 + <input type="text" name="form1-city" />
  10 + <input type="submit" value="Submit"/>
  11 + </form>
  12 +
  13 + <ul>
  14 + <documents>
  15 + <li><document/></li>
  16 + </documents>
  17 + </ul>
  18 + </body>
  19 +</html>
31 examples/example1/src/Application.hs
... ... @@ -0,0 +1,31 @@
  1 +{-# LANGUAGE TemplateHaskell #-}
  2 +{-# LANGUAGE MultiParamTypeClasses #-}
  3 +{-# LANGUAGE TypeSynonymInstances #-}
  4 +
  5 +module Application where
  6 +
  7 +import Data.Lens.Template
  8 +import Data.Lens.Common
  9 +
  10 +import Snap.Snaplet
  11 +import Snap.Snaplet.Heist
  12 +import Snap.Snaplet.MongoDB.Core
  13 +
  14 +import Control.Category ((.))
  15 +import Prelude hiding ((.))
  16 +
  17 +data App = App
  18 + { _heist :: Snaplet (Heist App)
  19 + , _database :: Snaplet MongoDB
  20 + }
  21 +
  22 +type AppHandler = Handler App App
  23 +
  24 +makeLens ''App
  25 +
  26 +instance HasHeist App where
  27 + heistLens = subSnaplet heist
  28 +
  29 +instance HasMongoDB App where
  30 + getMongoDB = getL (snapletValue . database)
  31 +
33 examples/example1/src/Example/Foo.hs
... ... @@ -0,0 +1,33 @@
  1 +{-# LANGUAGE OverloadedStrings #-}
  2 +{-# LANGUAGE ExtendedDefaultRules #-}
  3 +{-# LANGUAGE NoMonomorphismRestriction #-}
  4 +
  5 +module Example.Foo
  6 +( makeTeamDocument
  7 +, documentsSplice
  8 +, module Database.MongoDB
  9 +) where
  10 +
  11 +import qualified Data.Text as T
  12 +import Data.Text (Text)
  13 +import qualified Data.Text.Encoding as T (decodeUtf8)
  14 +
  15 +import Snap
  16 +import Snap.Snaplet
  17 +import Snap.Snaplet.MongoDB
  18 +
  19 +import Text.Templating.Heist
  20 +
  21 +import Database.MongoDB
  22 +import Control.Monad.Trans (liftIO)
  23 +
  24 +makeTeamDocument name city = ["name" =: name, "city" =: city]
  25 +
  26 +documentsSplice :: (HasMongoDB m) => Collection -> Splice (Handler m m)
  27 +documentsSplice collection = do
  28 + eres <- eitherWithDB $ rest =<< find (select [] collection)
  29 + res <- return $ either (const []) id eres
  30 + mapSplices (runChildrenWithText . showAs "document") res
  31 +
  32 +showAs :: (Show a) => Text -> a -> [(Text, Text)]
  33 +showAs name x = [(name, T.pack $ show x)]
56 examples/example1/src/Main.hs
... ... @@ -0,0 +1,56 @@
  1 +{-# LANGUAGE CPP #-}
  2 +{-# LANGUAGE TemplateHaskell #-}
  3 +
  4 +module Main where
  5 +
  6 +import Control.Exception (SomeException, try)
  7 +
  8 +import qualified Data.Text as T
  9 +
  10 +import Snap.Http.Server
  11 +import Snap.Snaplet
  12 +import Snap.Core
  13 +
  14 +import Application
  15 +
  16 +import System.IO
  17 +
  18 +import Site
  19 +
  20 +#ifdef DEVELOPMENT
  21 +import Snap.Loader.Devel
  22 +#else
  23 +import Snap.Loader.Prod
  24 +#endif
  25 +
  26 +main :: IO ()
  27 +main = do
  28 + (conf, site, cleanup) <- $(loadSnapTH [| getConf |]
  29 + 'getActions
  30 + ["resources/templates"])
  31 +
  32 + _ <- try $ httpServe conf $ site :: IO (Either SomeException ())
  33 + cleanup
  34 +
  35 +getConf :: IO (Config Snap ())
  36 +getConf = commandLineConfig defaultConfig
  37 +
  38 +
  39 +-- | This function generates the the site handler and cleanup action
  40 +-- from the configuration. In production mode, this action is only
  41 +-- run once. In development mode, this action is run whenever the
  42 +-- application is reloaded.
  43 +--
  44 +-- Development mode also makes sure that the cleanup actions are run
  45 +-- appropriately before shutdown. The cleanup action returned from
  46 +-- loadSnapTH should still be used after the server has stopped
  47 +-- handling requests, as the cleanup actions are only automatically
  48 +-- run when a reload is triggered.
  49 +--
  50 +-- This sample doesn't actually use the config passed in, but more
  51 +-- sophisticated code might.
  52 +getActions :: Config Snap () -> IO (Snap (), IO ())
  53 +getActions _ = do
  54 + (msgs, site, cleanup) <- runSnaplet app
  55 + hPutStrLn stderr $ T.unpack msgs
  56 + return (site, cleanup)
58 examples/example1/src/Site.hs
... ... @@ -0,0 +1,58 @@
  1 +{-# LANGUAGE OverloadedStrings #-}
  2 +
  3 +module Site
  4 +( app
  5 +) where
  6 +
  7 +import Data.ByteString (ByteString)
  8 +import Data.ByteString.UTF8 (toString)
  9 +
  10 +import Snap.Core
  11 +import Snap.Util.FileServe
  12 +
  13 +import Snap.Snaplet
  14 +import Snap.Snaplet.Heist
  15 +import Snap.Snaplet.MongoDB
  16 +
  17 +import Text.Templating.Heist
  18 +import Text.XmlHtml hiding (render)
  19 +
  20 +import Application
  21 +
  22 +import Example.Foo
  23 +
  24 +
  25 +indexView :: Handler App App ()
  26 +indexView = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"
  27 + where
  28 + indexSplices =
  29 + [ ("documents", documentsSplice "test-collection")
  30 + ]
  31 +
  32 +indexHandler :: Handler App App ()
  33 +indexHandler = insertTeamHandler >> redirect "/"
  34 +
  35 +insertTeamHandler :: Handler App App ()
  36 +insertTeamHandler = do
  37 + name <- getParamOr "form1-name" (redirect "/")
  38 + city <- getParamOr "form1-city" (redirect "/")
  39 + eitherWithDB $ insert "test-collection" $ makeTeamDocument name city
  40 + return ()
  41 + where getParamOr param action = getParam param >>= maybe action (return . toString)
  42 +
  43 +routes :: [(ByteString, Handler App App ())]
  44 +routes = [ ("/", method POST indexHandler)
  45 + , ("/", indexView)
  46 + , ("", with heist heistServe)
  47 + , ("", serveDirectory "resources/static")
  48 + ]
  49 +
  50 +app :: SnapletInit App App
  51 +app = makeSnaplet "app" "An snaplet example application." Nothing $ do
  52 + h <- nestSnaplet "heist" heist $ heistInit "resources/templates"
  53 + d <- nestSnaplet "database" database $ mongoDBInit 10 (host "127.0.0.1") "Snaplet-MongoDB"
  54 + addRoutes routes
  55 + return $ App h d
  56 +
  57 +
  58 +

0 comments on commit 51f057a

Please sign in to comment.
Something went wrong with that request. Please try again.