happstack-foundation 0.5.6 → 0.5.8
raw patch · 12 files changed
+1263/−3 lines, 12 filesdep ~happstack-serverdep ~monad-controlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: happstack-server, monad-control
API changes (from Hackage documentation)
+ Happstack.Foundation: AppCFE :: (CommonFormError [Input]) -> AppError
+ Happstack.Foundation: TextError :: Text -> AppError
+ Happstack.Foundation: data AppError
Files
- Happstack/Foundation.hs +2/−0
- examples/ControlV/ControlV.cabal +24/−0
- examples/ControlV/LICENSE +30/−0
- examples/ControlV/Main.hs +361/−0
- examples/ControlV/Setup.hs +2/−0
- examples/ControlV/style.css +165/−0
- examples/ControlVAuth/ControlVAuth.cabal +28/−0
- examples/ControlVAuth/LICENSE +30/−0
- examples/ControlVAuth/Main.hs +436/−0
- examples/ControlVAuth/Setup.hs +2/−0
- examples/ControlVAuth/style.css +165/−0
- happstack-foundation.cabal +18/−3
Happstack/Foundation.hs view
@@ -64,6 +64,8 @@ , module Text.Reform , module Text.Reform.Happstack , module Text.Reform.HSP.Text+ -- * Internals+ , AppError(..) ) where
+ examples/ControlV/ControlV.cabal view
@@ -0,0 +1,24 @@+Name: ControlV+Version: 0.1+Synopsis: yet another pasteboard+Description: A demo pasteboard intended to show off happstack-foundation+Homepage: http://www.happstack.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Category: Happstack+Build-type: Simple+Cabal-version: >=1.6+Data-files:+ style.css++Executable ControlV+ Main-Is: Main.hs+ Build-Depends: acid-state,+ base < 5,+ filepath,+ happstack-foundation >= 0.5 && < 0.6,+ ixset == 1.0.*,+ time == 1.4.*,+ text >= 0.11 && < 1.2
+ examples/ControlV/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Jeremy Shaw++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 Jeremy Shaw 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.
+ examples/ControlV/Main.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+module Main where++import Happstack.Foundation+import Control.Exception (bracket)+import Data.Acid.Local (createCheckpointAndClose)+import qualified Data.IxSet as IxSet+import Data.IxSet (IxSet, Indexable, Proxy(..), (@=), getEQ, getOne, ixSet, ixFun)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+import System.FilePath ((</>))++------------------------------------------------------------------------------+-- Model+------------------------------------------------------------------------------++-- | an id which uniquely identifies a paste+--+-- NOTE: 'PasteId 0' indicates that a 'Paste' has not been assigned an+-- id yet. Though.. I am not thrilled about 0 having special meaning+-- that is not enforced by the type system.+newtype PasteId = PasteId { unPasteId :: Integer }+ deriving (Eq, Ord, Read, Show, Enum, Data, Typeable)+$(deriveSafeCopy 0 'base ''PasteId)+$(derivePathInfo ''PasteId)++-- | The format of the paste. Currently we only support plain-text,+-- but later we might add support for Haskell syntax hightlighting,+-- etc.+data Format+ = PlainText+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Typeable)+$(deriveSafeCopy 0 'base ''Format)++-- | the meta-data for a 'Paste'+--+-- We break this out separately from the paste, because we often want+-- only the meta-data. For example, when generating a list of recent pastes.+data PasteMeta = PasteMeta+ { pasteId :: PasteId+ , title :: Text+ , nickname :: Text+ , format :: Format+ , pasted :: UTCTime+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''PasteMeta)++-- | a 'Paste'+data Paste = Paste+ { pasteMeta :: PasteMeta+ , paste :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''Paste)++-- | The 'Indexable Paste' instance will allow us to create an 'IxSet Paste'+--+-- We index on the 'PasteId' and the time it was pasted.+instance Indexable Paste where+ empty =+ ixSet [ ixFun $ (:[]) . pasteId . pasteMeta+ , ixFun $ (:[]) . pasted . pasteMeta+ ]++-- | record to store in acid-state+data CtrlVState = CtrlVState+ { pastes :: IxSet Paste+ , nextPasteId :: PasteId+ }+ deriving (Data, Typeable)+$(deriveSafeCopy 0 'base ''CtrlVState)++-- | initial value to use with acid-state when no prior state is found+initialCtrlVState :: CtrlVState+initialCtrlVState =+ CtrlVState { pastes = IxSet.empty+ , nextPasteId = PasteId 1+ }++------------------------------------------------------------------------------+-- Acid-State events+------------------------------------------------------------------------------++-- | add or update a paste+--+-- If the PasteId is '0', then update the paste to use the next unused PasteId and insert it into the IxSet.+--+-- Otherwise, we update the existing paste.+insertPaste :: Paste+ -> Update CtrlVState PasteId+insertPaste p@Paste{..}+ | pasteId pasteMeta == PasteId 0 =+ do cvs@CtrlVState{..} <- get+ put $ cvs { pastes = IxSet.insert (p { pasteMeta = pasteMeta { pasteId = nextPasteId }}) pastes+ , nextPasteId = succ nextPasteId+ }+ return nextPasteId+ | otherwise =+ do cvs@CtrlVState{..} <- get+ put $ cvs { pastes = IxSet.updateIx (pasteId pasteMeta) p pastes }+ return (pasteId pasteMeta)++-- | get a paste by it's 'PasteId'+getPasteById :: PasteId -> Query CtrlVState (Maybe Paste)+getPasteById pid = getOne . getEQ pid . pastes <$> ask++type Limit = Int+type Offset = Int++-- | get recent pastes+getRecentPastes :: Limit -- ^ maximum number of recent pastes to return+ -> Offset -- ^ number of pastes skip (useful for pagination)+ -> Query CtrlVState [PasteMeta]+getRecentPastes limit offset =+ do CtrlVState{..} <- ask+ return $ map pasteMeta $ take limit $ drop offset $ IxSet.toDescList (Proxy :: Proxy UTCTime) pastes++-- | now we need to tell acid-state which functions should be turn into+-- acid-state events.+$(makeAcidic ''CtrlVState+ [ 'getPasteById+ , 'getRecentPastes+ , 'insertPaste+ ])++------------------------------------------------------------------------------+-- Route+------------------------------------------------------------------------------++-- | All the routes for our web application+data Route+ = ViewRecent+ | ViewPaste PasteId+ | NewPaste+ | CSS+ deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | we will just use template haskell to derive the route mapping+$(derivePathInfo ''Route)++------------------------------------------------------------------------------+-- CtrlV type-aliases+------------------------------------------------------------------------------++-- | The foundation types are heavily parameterized -- but for our app+-- we can pin all the type parameters down.+type CtrlV' = FoundationT' Route Acid () IO+type CtrlV = XMLGenT CtrlV'+type CtrlVForm = FoundationForm Route Acid () IO++------------------------------------------------------------------------------+-- From demo-hsp Acid.hs+------------------------------------------------------------------------------++-- | 'Acid' holds all the 'AcidState' handles for this site.+data Acid = Acid+ { acidPaste :: AcidState CtrlVState+ }++instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) CtrlVState where+ getAcidState = acidPaste <$> getAcidSt++-- | run an action which takes 'Acid'.+--+-- Uses 'bracket' to open / initialize / close all the 'AcidState' handles.+--+-- WARNING: The database files should only be opened by one thread in+-- one application at a time. If you want to access the database from+-- multiple threads (which you almost certainly do), then simply pass+-- the 'Acid' handle to each thread.+withAcid :: Maybe FilePath -- ^ state directory+ -> (Acid -> IO a) -- ^ action+ -> IO a+withAcid mBasePath f =+ let basePath = fromMaybe "_state" mBasePath in+ bracket (openLocalStateFrom (basePath </> "paste") initialCtrlVState) (createCheckpointAndClose) $ \paste ->+ f (Acid paste)++------------------------------------------------------------------------------+-- appTemplate+------------------------------------------------------------------------------++-- | page template function+appTemplate :: ( EmbedAsChild CtrlV' headers+ , EmbedAsChild CtrlV' body+ ) =>+ Lazy.Text -- ^ page title+ -> headers -- ^ extra headers to add to \<head\> tag+ -> body -- ^ contents of \<body\> tag+ -> CtrlV Response+appTemplate ttl moreHdrs bdy =+ do html <- defaultTemplate ttl+ <%><link rel="stylesheet" href=CSS type="text/css" media="screen" /><% moreHdrs %></%>+ <%>+ <div id="logo">^V</div>+ <ul class="menu">+ <li><a href=NewPaste>new paste</a></li>+ <li><a href=ViewRecent>recent pastes</a></li>+ </ul>+ <% bdy %>+ </%>+ return (toResponse html)++-- | This makes it easy to embed a PasteId in an HSP template+instance EmbedAsChild CtrlV' PasteId where+ asChild (PasteId i) = asChild ('#' : show i)++-- | This makes it easy to embed a timestamp into an HSP+-- template. 'show' provides way too much precision, so something+-- using formatTime would be better.+instance EmbedAsChild CtrlV' UTCTime where+ asChild time = asChild (show time)++------------------------------------------------------------------------------+-- Pages+------------------------------------------------------------------------------++-- | page handler for 'ViewRecent'+viewRecentPage :: CtrlV Response+viewRecentPage =+ do method GET+ recent <- query (GetRecentPastes 20 0)+ case recent of+ [] -> appTemplate "Recent Pastes" () <p>There are no pastes yet.</p>+ _ -> appTemplate "Recent Pastes" () $+ <%>+ <h1>Recent Pastes</h1>+ <table>+ <thead>+ <tr>+ <th>id</th>+ <th>title</th>+ <th>author</th>+ <th>date</th>+ <th>format</th>+ </tr>+ </thead>+ <tbody>+ <% mapM mkTableRow recent %>+ </tbody>+ </table>+ </%>+ where+ mkTableRow PasteMeta{..} =+ <tr>+ <td><a href=(ViewPaste pasteId)><% show $ unPasteId pasteId %></a></td>+ <td><a href=(ViewPaste pasteId)><% title %></a></td>+ <td><% nickname %></td>+ <td><% pasted %></td>+ <td><% show format %></td>+ </tr>++-- | page handler for 'ViewPaste'+viewPastePage :: PasteId -> CtrlV Response+viewPastePage pid =+ do method GET+ mPaste <- query (GetPasteById pid)+ case mPaste of+ Nothing ->+ do notFound ()+ appTemplate "Paste not found." () $+ <p>Paste <% pid %> could not be found.</p>+ (Just (Paste (PasteMeta{..}) paste)) ->+ do ok ()+ appTemplate (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $+ <div class="paste">+ <dl class="paste-header">+ <dt>Paste:</dt><dd><a href=(ViewPaste pid)><% pid %></a></dd>+ <dt>Title:</dt><dd><% title %></dd>+ <dt>Author:</dt><dd><% nickname %></dd>+ </dl>+ <div class="paste-body">+ <% formatPaste format paste %>+ </div>+ </div>++-- | convert the paste to HTML. We currently only support 'PlainText',+-- but eventually it might do syntax hightlighting, markdown, etc.+--+-- Note that we do not have to worry about escaping the txt+-- value.. that is done automatically by HSP.+formatPaste :: Format -> Text -> CtrlV XML+formatPaste PlainText txt =+ <pre><% txt %></pre>++-- | page handler for 'NewPaste'+newPastePage :: CtrlV Response+newPastePage =+ do here <- whereami+ appTemplate "Add a Paste" () $+ <%>+ <h1>Add a paste</h1>+ <% reform (form here) "add" success Nothing pasteForm %>+ </%>+ where+ success :: Paste -> CtrlV Response+ success paste =+ do pid <- update (InsertPaste paste)+ seeOtherURL (ViewPaste pid)++-- | the 'Form' used for entering a new paste+pasteForm :: CtrlVForm Paste+pasteForm =+ (fieldset $+ ul $+ (,,,) <$> (li $ label <span>title</span> ++> (inputText "" `transformEither` required) <++ errorList)+ <*> (li $ label <span>nick</span> ++> (inputText "" `transformEither` required) <++ errorList)+ <*> (li $ label <span>format</span> ++> formatForm)+ <*> (li $ label <div>paste</div> ++> errorList ++> (textarea 80 25 "" `transformEither` required))+ <* inputSubmit "paste!"+ ) `transformEitherM` toPaste+ where+ formatForm =+ select [(a, show a) | a <- [minBound .. maxBound]] (== PlainText)+ toPaste (ttl, nick, fmt, bdy) =+ do now <- liftIO getCurrentTime+ return $ Right $+ (Paste { pasteMeta = PasteMeta { pasteId = PasteId 0+ , title = ttl+ , nickname = nick+ , format = fmt+ , pasted = now+ }+ , paste = bdy+ })+ required txt+ | Text.null txt = Left "Required"+ | otherwise = Right txt++------------------------------------------------------------------------------+-- route+------------------------------------------------------------------------------++-- | the route mapping function+route :: Route -> CtrlV Response+route url =+ case url of+ ViewRecent -> viewRecentPage+ (ViewPaste pid) -> viewPastePage pid+ NewPaste -> newPastePage+ CSS -> serveFile (asContentType "text/css") "style.css"++------------------------------------------------------------------------------+-- main+------------------------------------------------------------------------------++-- | start the app. listens on port 8000.+main :: IO ()+main = withAcid Nothing $ \acid -> do+ simpleApp id+ defaultConf+ (AcidUsing acid)+ ()+ ViewRecent+ ""+ route
+ examples/ControlV/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/ControlV/style.css view
@@ -0,0 +1,165 @@+body+{+ font-size: 16px;+ font-family: sans-serif;+ padding-left: 32px;+ width: 45em;+ margin-left: 2em;+}+++h1, h2, h3, h4+{+ font-family: sans-serif;+ font-weight: normal;+}++a+{+ text-decoration: none;+ color: #1179BE;+}++a:hover+{+ text-decoration: underline;+}++/* logo & menu theme */++#logo+{+ vertical-align: middle;+ display: inline;+ font-size: 3em;+ font-weight: bold;+ color: black;+ margin-right: 16px;+}+++ul.menu+{+ display: inline-block;+ vertical-align: middle;+ list-style-type: none;+ background: #16A5C9;+ border-radius: 10px;+ padding: 0;+ margin: 0;+}++.menu li+{+ display: inline-block;+ border-right: 3px solid white;+}++.menu li:last-child+{+ border-right: none;+}++.menu a+{+ padding: 1em;+ display: inline-block;+ text-decoration: none;+ color: white;+ text-shadow: 1px 1px #aaa;+}++.menu a:visited+{+ color: white;+}++/* form theme */++fieldset+{+ margin: 0;+ padding: 0;+ border: none;+}++fieldset > ul+{+ margin: 0;+ padding: 0;++ list-style-type: none;+}+++label+{+ font-weight: bold;+}++label > span+{+ min-width: 64px;+ display: inline-block;+}++input, textarea+{+ border: 1px solid #aaa;+ box-shadow: 2px 2px 2px #aaa;+}++ul.reform-error-list+{+ color: red;+ display: inline;+ padding: 1em;+}++.reform-error-list li+{+ display: inline-block;+ list-style-type: square;+}++/* paste theme */++dl.paste-header+{+ font-family: monospace;+ line-height: 1.5em;+ border-top: 1px solid black;+ border-bottom: 1px solid black;+}++.paste-header dt+{+ float: left;+ clear: left;+ font-weight: bold;+}++.paste-header dd+{+ margin-left: 8em;+}++/* paste list theme */++table+{+ border-spacing: 0;+ line-height: 2;+}++th+{+ border-bottom: 2px solid #66a;+ text-align: left;+ font-weight: bold;+}++td+{+ padding-right: 3em;+}
+ examples/ControlVAuth/ControlVAuth.cabal view
@@ -0,0 +1,28 @@+Name: ControlVAuth+Version: 0.1+Synopsis: yet another pasteboard+Description: A demo pasteboard intended to show off happstack-foundation+Homepage: http://www.happstack.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Category: Happstack+Build-type: Simple+Cabal-version: >=1.6+Data-files:+ style.css++Executable ControlVAuth+ Main-Is: Main.hs+ Build-Depends: base < 5+ , happstack-foundation >= 0.5 && < 0.6+ , ixset == 1.0.*+ , time == 1.4.*+ , text >= 0.11 && < 1.2+ , happstack-authenticate >= 0.10.6+ , acid-state+ , hsp+ , blaze-html+ , happstack-hsp+ , filepath
+ examples/ControlVAuth/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Jeremy Shaw++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 Jeremy Shaw 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.
+ examples/ControlVAuth/Main.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+module Main where++import Happstack.Foundation+import qualified Data.IxSet as IxSet+import Data.IxSet (IxSet, Indexable, Proxy(..), (@=), getEQ, getOne, ixSet, ixFun)+import Data.Text (Text)+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+-- Added for auth++import Happstack.Auth+import Happstack.Auth.Core.Auth+import Happstack.Auth.Core.Profile+import Happstack.Auth.Blaze.Templates+import Control.Exception (bracket)+import Data.Acid.Local (createCheckpointAndClose)+import System.FilePath ((</>))+import Data.Maybe+import System.Environment++-- Added for Blaze under Auth+import qualified Happstack.Server.HSP.HTML as HTML+import HSP (toName)+import HSP.XML as HTML+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.Text (renderHtml)++------------------------------------------------------------------------------+-- Model+------------------------------------------------------------------------------++-- | an id which uniquely identifies a paste+--+-- NOTE: 'PasteId 0' indicates that a 'Paste' has not been assigned an+-- id yet. Though.. I am not thrilled about 0 having special meaning+-- that is not enforced by the type system.+newtype PasteId = PasteId { unPasteId :: Integer }+ deriving (Eq, Ord, Read, Show, Enum, Data, Typeable)+$(deriveSafeCopy 0 'base ''PasteId)+$(derivePathInfo ''PasteId)++-- | The format of the paste. Currently we only support plain-text,+-- but later we might add support for Haskell syntax hightlighting,+-- etc.+data Format+ = PlainText+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Typeable)+$(deriveSafeCopy 0 'base ''Format)++-- | the meta-data for a 'Paste'+--+-- We break this out separately from the paste, because we often want+-- only the meta-data. For example, when generating a list of recent pastes.+data PasteMeta = PasteMeta+ { pasteId :: PasteId+ , title :: Text+ , nickname :: Text+ , format :: Format+ , pasted :: UTCTime+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''PasteMeta)++-- | a 'Paste'+data Paste = Paste+ { pasteMeta :: PasteMeta+ , paste :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''Paste)++-- | The 'Indexable Paste' instance will allow us to create an 'IxSet Paste'+--+-- We index on the 'PasteId' and the time it was pasted.+instance Indexable Paste where+ empty =+ ixSet [ ixFun $ (:[]) . pasteId . pasteMeta+ , ixFun $ (:[]) . pasted . pasteMeta+ ]++-- | record to store in acid-state+data CtrlVState = CtrlVState+ { pastes :: IxSet Paste+ , nextPasteId :: PasteId+ }+ deriving (Data, Typeable)+$(deriveSafeCopy 0 'base ''CtrlVState)++-- | initial value to use with acid-state when no prior state is found+initialCtrlVState :: CtrlVState+initialCtrlVState =+ CtrlVState { pastes = IxSet.empty+ , nextPasteId = PasteId 1+ }++------------------------------------------------------------------------------+-- Acid-State events+------------------------------------------------------------------------------++-- | add or update a paste+--+-- If the PasteId is '0', then update the paste to use the next unused PasteId and insert it into the IxSet.+--+-- Otherwise, we update the existing paste.+insertPaste :: Paste+ -> Update CtrlVState PasteId+insertPaste p@Paste{..}+ | pasteId pasteMeta == PasteId 0 =+ do cvs@CtrlVState{..} <- get+ put $ cvs { pastes = IxSet.insert (p { pasteMeta = pasteMeta { pasteId = nextPasteId }}) pastes+ , nextPasteId = succ nextPasteId+ }+ return nextPasteId+ | otherwise =+ do cvs@CtrlVState{..} <- get+ put $ cvs { pastes = IxSet.updateIx (pasteId pasteMeta) p pastes }+ return (pasteId pasteMeta)++-- | get a paste by it's 'PasteId'+getPasteById :: PasteId -> Query CtrlVState (Maybe Paste)+getPasteById pid = getOne . getEQ pid . pastes <$> ask++type Limit = Int+type Offset = Int++-- | get recent pastes+getRecentPastes :: Limit -- ^ maximum number of recent pastes to return+ -> Offset -- ^ number of pastes skip (useful for pagination)+ -> Query CtrlVState [PasteMeta]+getRecentPastes limit offset =+ do CtrlVState{..} <- ask+ return $ map pasteMeta $ take limit $ drop offset $ IxSet.toDescList (Proxy :: Proxy UTCTime) pastes++-- | now we need to tell acid-state which functions should be turn into+-- acid-state events.+$(makeAcidic ''CtrlVState+ [ 'getPasteById+ , 'getRecentPastes+ , 'insertPaste+ ])++------------------------------------------------------------------------------+-- Route+------------------------------------------------------------------------------++-- | All the routes for our web application+data Route+ = ViewRecent+ | ViewPaste PasteId+ | NewPaste+ | CSS+ | U_AuthProfile AuthProfileURL+ deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | we will just use template haskell to derive the route mapping+$(derivePathInfo ''Route)++------------------------------------------------------------------------------+-- CtrlV type-aliases+------------------------------------------------------------------------------++-- | The foundation types are heavily parameterized -- but for our app+-- we can pin all the type parameters down.++type CtrlV' = FoundationT' Route Acid () IO+type CtrlV = XMLGenT CtrlV'+type CtrlVForm = FoundationForm Route Acid () IO++------------------------------------------------------------------------------+-- From demo-hsp Acid.hs+------------------------------------------------------------------------------++-- | 'Acid' holds all the 'AcidState' handles for this site.+data Acid = Acid+ { acidAuth :: AcidState AuthState+ , acidProfile :: AcidState ProfileState+ , acidPaste :: AcidState CtrlVState+ }++instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) AuthState where+ getAcidState = acidAuth <$> getAcidSt++instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) ProfileState where+ getAcidState = acidProfile <$> getAcidSt++instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) CtrlVState where+ getAcidState = acidPaste <$> getAcidSt++-- | run an action which takes 'Acid'.+--+-- Uses 'bracket' to open / initialize / close all the 'AcidState' handles.+--+-- WARNING: The database files should only be opened by one thread in+-- one application at a time. If you want to access the database from+-- multiple threads (which you almost certainly do), then simply pass+-- the 'Acid' handle to each thread.+withAcid :: Maybe FilePath -- ^ state directory+ -> (Acid -> IO a) -- ^ action+ -> IO a+withAcid mBasePath f =+ let basePath = fromMaybe "_state" mBasePath in+ bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) (createCheckpointAndClose) $ \auth ->+ bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createCheckpointAndClose) $ \profile ->+ bracket (openLocalStateFrom (basePath </> "paste") initialCtrlVState) (createCheckpointAndClose) $ \paste ->+ f (Acid auth profile paste)++------------------------------------------------------------------------------+-- appTemplate+------------------------------------------------------------------------------++-- | page template function+appTemplate :: ( EmbedAsChild CtrlV' headers+ , EmbedAsChild CtrlV' body+ ) =>+ Lazy.Text -- ^ page title+ -> headers -- ^ extra headers to add to \<head\> tag+ -> body -- ^ contents of \<body\> tag+ -> CtrlV Response+appTemplate ttl moreHdrs bdy =+ do html <- defaultTemplate ttl+ <%><link rel="stylesheet" href=CSS type="text/css" media="screen" /><% moreHdrs %></%>+ <%>+ <div id="logo">^V</div>+ <ul class="menu">+ <li><a href=NewPaste>new paste</a></li>+ <li><a href=ViewRecent>recent pastes</a></li>+ </ul>+ <% do mUserId <- join $ liftM2 getUserId getAcidState getAcidState++ -- Debugging+ -- authState <- query' acidAuth AskAuthState+ -- let authDump = traceMsg "authState: " $ ppDoc authState++ case mUserId of+ Nothing -> do+ <ul class="auth">+ <li>You are not logged in</li>+ <li><a href=(U_AuthProfile $ AuthURL A_Login)>login</a></li>+ <li><a href=(U_AuthProfile $ AuthURL A_CreateAccount)>create account</a></li>+ </ul>+ (Just uid) -> do+ <ul class="auth">+ <li>You are logged in with profile <% Lazy.pack $ show $ unUserId uid %></li>+ -- Debugging+ -- <li><% show authDump %></li>+ <li><a href=(U_AuthProfile $ AuthURL A_Logout)>logout</a></li>+ <li><a href=(U_AuthProfile $ AuthURL A_AddAuth)>add another auth mode to your profile</a></li>+ </ul>+ %>+ <% bdy %>+ </%>+ return (toResponse html)++-- | This makes it easy to embed a PasteId in an HSP template+instance EmbedAsChild CtrlV' PasteId where+ asChild (PasteId i) = asChild ('#' : show i)++-- | This makes it easy to embed a timestamp into an HSP+-- template. 'show' provides way too much precision, so something+-- using formatTime would be better.+instance EmbedAsChild CtrlV' UTCTime where+ asChild time = asChild (show time)++-- | This instance allows blaze-html markup to be easily embedded.+-- It is required for the happstack-authentication support.+instance EmbedAsChild CtrlV' Html where+ asChild html = asChild (HTML.CDATA False (renderHtml html))++------------------------------------------------------------------------------+-- Pages+------------------------------------------------------------------------------++-- | page handler for 'ViewRecent'+viewRecentPage :: CtrlV Response+viewRecentPage =+ do method GET+ recent <- query (GetRecentPastes 20 0)+ case recent of+ [] -> appTemplate "Recent Pastes" () <p>There are no pastes yet.</p>+ _ -> appTemplate "Recent Pastes" () $+ <%>+ <h1>Recent Pastes</h1>+ <table>+ <thead>+ <tr>+ <th>id</th>+ <th>title</th>+ <th>author</th>+ <th>date</th>+ <th>format</th>+ </tr>+ </thead>+ <tbody>+ <% mapM mkTableRow recent %>+ </tbody>+ </table>+ </%>+ where+ mkTableRow PasteMeta{..} =+ <tr>+ <td><a href=(ViewPaste pasteId)><% show $ unPasteId pasteId %></a></td>+ <td><a href=(ViewPaste pasteId)><% title %></a></td>+ <td><% nickname %></td>+ <td><% pasted %></td>+ <td><% show format %></td>+ </tr>++-- | page handler for 'ViewPaste'+viewPastePage :: PasteId -> CtrlV Response+viewPastePage pid =+ do method GET+ mPaste <- query (GetPasteById pid)+ case mPaste of+ Nothing ->+ do notFound ()+ appTemplate "Paste not found." () $+ <p>Paste <% pid %> could not be found.</p>+ (Just (Paste (PasteMeta{..}) paste)) ->+ do ok ()+ appTemplate (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $+ <div class="paste">+ <dl class="paste-header">+ <dt>Paste:</dt><dd><a href=(ViewPaste pid)><% pid %></a></dd>+ <dt>Title:</dt><dd><% title %></dd>+ <dt>Author:</dt><dd><% nickname %></dd>+ </dl>+ <div class="paste-body">+ <% formatPaste format paste %>+ </div>+ </div>++-- | convert the paste to HTML. We currently only support 'PlainText',+-- but eventually it might do syntax hightlighting, markdown, etc.+--+-- Note that we do not have to worry about escaping the txt+-- value.. that is done automatically by HSP.+formatPaste :: Format -> Text -> CtrlV XML+formatPaste PlainText txt =+ <pre><% txt %></pre>++-- | page handler for 'NewPaste'+newPastePage :: CtrlV Response+newPastePage =+ do here <- whereami+ mUserId <- join $ liftM2 getUserId getAcidState getAcidState+ case mUserId of+ Nothing ->+ appTemplate "Add a Paste" () $+ <%>+ <h1>You Are Not Logged In</h1>+ </%>+ (Just uid) ->+ appTemplate "Add a Paste" () $+ <%>+ <h1>Add a paste</h1>+ <% reform (form here) "add" success Nothing pasteForm %>+ </%>+ where+ success :: Paste -> CtrlV Response+ success paste =+ do pid <- update (InsertPaste paste)+ seeOtherURL (ViewPaste pid)++-- | the 'Form' used for entering a new paste+pasteForm :: CtrlVForm Paste+pasteForm =+ (fieldset $+ ul $+ (,,,) <$> (li $ label <span>title</span> ++> (inputText "" `transformEither` required) <++ errorList)+ <*> (li $ label <span>nick</span> ++> (inputText "" `transformEither` required) <++ errorList)+ <*> (li $ label <span>format</span> ++> formatForm)+ <*> (li $ label <div>paste</div> ++> errorList ++> (textarea 80 25 "" `transformEither` required))+ <* inputSubmit "paste!"+ ) `transformEitherM` toPaste+ where+ formatForm =+ select [(a, show a) | a <- [minBound .. maxBound]] (== PlainText)+ toPaste (ttl, nick, fmt, bdy) =+ do now <- liftIO getCurrentTime+ return $ Right $+ (Paste { pasteMeta = PasteMeta { pasteId = PasteId 0+ , title = ttl+ , nickname = nick+ , format = fmt+ , pasted = now+ }+ , paste = bdy+ })+ required txt+ | Text.null txt = Left "Required"+ | otherwise = Right txt++------------------------------------------------------------------------------+-- route+------------------------------------------------------------------------------++-- | the route mapping function+route :: Text -> Route -> CtrlV Response+route baseURL url =+ case url of+ -- FIXME: replace the ViewRecent thing here with "go back to+ -- the last page we were on". - rlpowell+ (U_AuthProfile authProfileURL) ->+ do vr <- showURL ViewRecent+ acidAuth <- getAcidState :: CtrlV (AcidState AuthState)+ acidProfile <- getAcidState :: CtrlV (AcidState ProfileState)+ rf <- askRouteFn+ unRouteT (handleAuthProfileRouteT acidAuth acidProfile (\s -> appTemplate (Lazy.pack s)) Nothing (Just baseURL) vr authProfileURL) (rf . U_AuthProfile)+ ViewRecent -> viewRecentPage+ (ViewPaste pid) -> viewPastePage pid+ NewPaste -> newPastePage+ CSS -> serveFile (asContentType "text/css") "style.css"++------------------------------------------------------------------------------+-- main+------------------------------------------------------------------------------++-- | start the app. listens on port 8000.+main :: IO ()+main = withAcid Nothing $ \acid -> do+ args <- getArgs+ let appPort = if (length args > 0) then (read (args !! 0) :: Int) else 8000+ let hosturl = if (length args > 1) then (Text.pack ((args !! 1) :: String)) else (Text.pack "http://localhost:8000")+ simpleApp id+ defaultConf { httpConf = nullConf {+ port = appPort+ }+ }+ (AcidUsing acid)+ ()+ ViewRecent+ hosturl+ (route hosturl)
+ examples/ControlVAuth/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/ControlVAuth/style.css view
@@ -0,0 +1,165 @@+body+{+ font-size: 16px;+ font-family: sans-serif;+ padding-left: 32px;+ width: 45em;+ margin-left: 2em;+}+++h1, h2, h3, h4+{+ font-family: sans-serif;+ font-weight: normal;+}++a+{+ text-decoration: none;+ color: #1179BE;+}++a:hover+{+ text-decoration: underline;+}++/* logo & menu theme */++#logo+{+ vertical-align: middle;+ display: inline;+ font-size: 3em;+ font-weight: bold;+ color: black;+ margin-right: 16px;+}+++ul.menu+{+ display: inline-block;+ vertical-align: middle;+ list-style-type: none;+ background: #16A5C9;+ border-radius: 10px;+ padding: 0;+ margin: 0;+}++.menu li+{+ display: inline-block;+ border-right: 3px solid white;+}++.menu li:last-child+{+ border-right: none;+}++.menu a+{+ padding: 1em;+ display: inline-block;+ text-decoration: none;+ color: white;+ text-shadow: 1px 1px #aaa;+}++.menu a:visited+{+ color: white;+}++/* form theme */++fieldset+{+ margin: 0;+ padding: 0;+ border: none;+}++fieldset > ul, fieldset > ol+{+ margin: 0;+ padding: 0;++ list-style-type: none;+}+++label+{+ font-weight: bold;+}++label > span+{+ min-width: 64px;+ display: inline-block;+}++input, textarea+{+ border: 1px solid #aaa;+ box-shadow: 2px 2px 2px #aaa;+}++ul.reform-error-list+{+ color: red;+ display: inline;+ padding: 1em;+}++.reform-error-list li+{+ display: inline-block;+ list-style-type: square;+}++/* paste theme */++dl.paste-header+{+ font-family: monospace;+ line-height: 1.5em;+ border-top: 1px solid black;+ border-bottom: 1px solid black;+}++.paste-header dt+{+ float: left;+ clear: left;+ font-weight: bold;+}++.paste-header dd+{+ margin-left: 8em;+}++/* paste list theme */++table+{+ border-spacing: 0;+ line-height: 2;+}++th+{+ border-bottom: 2px solid #66a;+ text-align: left;+ font-weight: bold;+}++td+{+ padding-right: 3em;+}
happstack-foundation.cabal view
@@ -1,5 +1,5 @@ Name: happstack-foundation-Version: 0.5.6+Version: 0.5.8 Synopsis: Glue code for using Happstack with acid-state, web-routes, reform, and HSP Description: happstack-foundation is a library which builds on top of existing components to provide a powerful and type-safe environment for web development. It uses:@@ -21,17 +21,32 @@ Category: Happstack Build-type: Simple Cabal-version: >=1.6+Data-Files:+ examples/ControlV/ControlV.cabal+ examples/ControlV/LICENSE+ examples/ControlV/style.css+ examples/ControlV/Setup.hs+ examples/ControlV/Main.hs+ examples/ControlVAuth/LICENSE+ examples/ControlVAuth/style.css+ examples/ControlVAuth/ControlVAuth.cabal+ examples/ControlVAuth/Setup.hs+ examples/ControlVAuth/Main.hs +source-repository head+ type: git+ location: https://github.com/Happstack/happstack-foundation.git+ Library Exposed-modules: Happstack.Foundation Build-Depends: base < 5, acid-state >= 0.7 && < 0.13, happstack-hsp == 7.3.*,- happstack-server >= 7.0 && < 7.4,+ happstack-server >= 7.0 && < 7.5, hsp >= 0.9 && < 0.11, lifted-base >= 0.1 && < 0.3,- monad-control == 0.3.*,+ monad-control >= 0.3 && < 1.1, mtl >= 2.0 && < 2.3, reform == 0.2.*, reform-happstack == 0.2.*,