diff --git a/Happstack/Foundation.hs b/Happstack/Foundation.hs --- a/Happstack/Foundation.hs +++ b/Happstack/Foundation.hs @@ -64,6 +64,8 @@ , module Text.Reform , module Text.Reform.Happstack , module Text.Reform.HSP.Text + -- * Internals + , AppError(..) ) where diff --git a/examples/ControlV/ControlV.cabal b/examples/ControlV/ControlV.cabal new file mode 100644 --- /dev/null +++ b/examples/ControlV/ControlV.cabal @@ -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 diff --git a/examples/ControlV/LICENSE b/examples/ControlV/LICENSE new file mode 100644 --- /dev/null +++ b/examples/ControlV/LICENSE @@ -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. diff --git a/examples/ControlV/Main.hs b/examples/ControlV/Main.hs new file mode 100644 --- /dev/null +++ b/examples/ControlV/Main.hs @@ -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 \ tag + -> body -- ^ contents of \ tag + -> CtrlV Response +appTemplate ttl moreHdrs bdy = + do html <- defaultTemplate ttl + <%><% moreHdrs %> + <%> + + + <% 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" ()

There are no pastes yet.

+ _ -> appTemplate "Recent Pastes" () $ + <%> +

Recent Pastes

+ + + + + + + + + + + + <% mapM mkTableRow recent %> + +
idtitleauthordateformat
+ + where + mkTableRow PasteMeta{..} = + + <% show $ unPasteId pasteId %> + <% title %> + <% nickname %> + <% pasted %> + <% show format %> + + +-- | 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." () $ +

Paste <% pid %> could not be found.

+ (Just (Paste (PasteMeta{..}) paste)) -> + do ok () + appTemplate (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $ +
+
+
Paste:
<% pid %>
+
Title:
<% title %>
+
Author:
<% nickname %>
+
+
+ <% formatPaste format paste %> +
+
+ +-- | 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 = + 
<% txt %>
+ +-- | page handler for 'NewPaste' +newPastePage :: CtrlV Response +newPastePage = + do here <- whereami + appTemplate "Add a Paste" () $ + <%> +

Add a paste

+ <% 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 title ++> (inputText "" `transformEither` required) <++ errorList) + <*> (li $ label nick ++> (inputText "" `transformEither` required) <++ errorList) + <*> (li $ label format ++> formatForm) + <*> (li $ label
paste
++> 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 diff --git a/examples/ControlV/Setup.hs b/examples/ControlV/Setup.hs new file mode 100644 --- /dev/null +++ b/examples/ControlV/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/ControlV/style.css b/examples/ControlV/style.css new file mode 100644 --- /dev/null +++ b/examples/ControlV/style.css @@ -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; +} diff --git a/examples/ControlVAuth/ControlVAuth.cabal b/examples/ControlVAuth/ControlVAuth.cabal new file mode 100644 --- /dev/null +++ b/examples/ControlVAuth/ControlVAuth.cabal @@ -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 diff --git a/examples/ControlVAuth/LICENSE b/examples/ControlVAuth/LICENSE new file mode 100644 --- /dev/null +++ b/examples/ControlVAuth/LICENSE @@ -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. diff --git a/examples/ControlVAuth/Main.hs b/examples/ControlVAuth/Main.hs new file mode 100644 --- /dev/null +++ b/examples/ControlVAuth/Main.hs @@ -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 \ tag + -> body -- ^ contents of \ tag + -> CtrlV Response +appTemplate ttl moreHdrs bdy = + do html <- defaultTemplate ttl + <%><% moreHdrs %> + <%> + + + <% do mUserId <- join $ liftM2 getUserId getAcidState getAcidState + + -- Debugging + -- authState <- query' acidAuth AskAuthState + -- let authDump = traceMsg "authState: " $ ppDoc authState + + case mUserId of + Nothing -> do + + (Just uid) -> do + + %> + <% 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" ()

There are no pastes yet.

+ _ -> appTemplate "Recent Pastes" () $ + <%> +

Recent Pastes

+ + + + + + + + + + + + <% mapM mkTableRow recent %> + +
idtitleauthordateformat
+ + where + mkTableRow PasteMeta{..} = + + <% show $ unPasteId pasteId %> + <% title %> + <% nickname %> + <% pasted %> + <% show format %> + + +-- | 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." () $ +

Paste <% pid %> could not be found.

+ (Just (Paste (PasteMeta{..}) paste)) -> + do ok () + appTemplate (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $ +
+
+
Paste:
<% pid %>
+
Title:
<% title %>
+
Author:
<% nickname %>
+
+
+ <% formatPaste format paste %> +
+
+ +-- | 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 = + 
<% txt %>
+ +-- | 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" () $ + <%> +

You Are Not Logged In

+ + (Just uid) -> + appTemplate "Add a Paste" () $ + <%> +

Add a paste

+ <% 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 title ++> (inputText "" `transformEither` required) <++ errorList) + <*> (li $ label nick ++> (inputText "" `transformEither` required) <++ errorList) + <*> (li $ label format ++> formatForm) + <*> (li $ label
paste
++> 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) diff --git a/examples/ControlVAuth/Setup.hs b/examples/ControlVAuth/Setup.hs new file mode 100644 --- /dev/null +++ b/examples/ControlVAuth/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/ControlVAuth/style.css b/examples/ControlVAuth/style.css new file mode 100644 --- /dev/null +++ b/examples/ControlVAuth/style.css @@ -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; +} diff --git a/happstack-foundation.cabal b/happstack-foundation.cabal --- a/happstack-foundation.cabal +++ b/happstack-foundation.cabal @@ -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.*,