diff --git a/examples/ControlV/ControlV.cabal b/examples/ControlV/ControlV.cabal --- a/examples/ControlV/ControlV.cabal +++ b/examples/ControlV/ControlV.cabal @@ -20,5 +20,5 @@ filepath, happstack-foundation >= 0.5 && < 0.6, ixset == 1.0.*, - time == 1.4.*, - text >= 0.11 && < 1.2 + time >= 1.4 && < 1.6, + text >= 0.11 && < 1.3 diff --git a/examples/ControlVAuth/ControlVAuth.cabal b/examples/ControlVAuth/ControlVAuth.cabal --- a/examples/ControlVAuth/ControlVAuth.cabal +++ b/examples/ControlVAuth/ControlVAuth.cabal @@ -14,15 +14,20 @@ style.css Executable ControlVAuth + build-tools: hsx2hs 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 + , happstack-foundation >= 0.5 && < 0.6 + , hsx2hs + , jmacro >= 0.6.9 && < 0.7 + , ixset == 1.0.* + , time >= 1.4 && < 1.6 + , text >= 0.11 && < 1.3 + , happstack-authenticate >= 2.3 && < 2.4 + , happstack-jmacro >= 7.0 && < 7.1 , hsp - , blaze-html , happstack-hsp , filepath + , lens + , userid diff --git a/examples/ControlVAuth/Main.hs b/examples/ControlVAuth/Main.hs --- a/examples/ControlVAuth/Main.hs +++ b/examples/ControlVAuth/Main.hs @@ -1,32 +1,35 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, 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 Control.Exception (bracket, finally) +import Control.Lens ((^.)) +import Data.Acid.Local (createCheckpointAndClose) +import qualified Data.IxSet as IxSet +import Data.IxSet (IxSet, Indexable, Proxy(..), (@=), getEQ, getOne, ixSet, ixFun) import Data.Maybe -import System.Environment +import Data.Text (Text) +import Data.UserId (UserId(..)) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text as Text +import Data.Time.Clock (UTCTime, getCurrentTime) +import Happstack.Authenticate.Core (AuthenticateState, AuthenticateConfig(..), AuthenticateURL(Controllers), Username, getToken, tokenUser, unUsername, username, usernamePolicy) +import Happstack.Authenticate.Route (initAuthentication) +import Happstack.Authenticate.Password.Core (PasswordConfig(..)) +import Happstack.Authenticate.Password.Route (initPassword) +-- import Happstack.Authenticate.Password.URL(PasswordURL(..)) +-- import Happstack.Authenticate.OpenId.Core (OpenIdState) +import Happstack.Authenticate.OpenId.Route (initOpenId) +-- import Happstack.Authenticate.OpenId.URL (OpenIdURL(..)) --- 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) +import Happstack.Server.JMacro () +import Happstack.Foundation +import HSP (toName) +import HSP.XML as HTML +import Language.Javascript.JMacro +import System.Environment +import System.FilePath (()) ------------------------------------------------------------------------------ -- Model @@ -56,8 +59,9 @@ -- only the meta-data. For example, when generating a list of recent pastes. data PasteMeta = PasteMeta { pasteId :: PasteId + , replyTo :: Maybe PasteId , title :: Text - , nickname :: Text + , nickname :: Username , format :: Format , pasted :: UTCTime } @@ -77,8 +81,8 @@ -- We index on the 'PasteId' and the time it was pasted. instance Indexable Paste where empty = - ixSet [ ixFun $ (:[]) . pasteId . pasteMeta - , ixFun $ (:[]) . pasted . pasteMeta + ixSet [ ixFun $ (:[]) . pasteId . pasteMeta + , ixFun $ (:[]) . pasted . pasteMeta ] -- | record to store in acid-state @@ -134,11 +138,18 @@ do CtrlVState{..} <- ask return $ map pasteMeta $ take limit $ drop offset $ IxSet.toDescList (Proxy :: Proxy UTCTime) pastes +-- | get a list of all paste ids +getPasteIds :: Query CtrlVState [PasteId] +getPasteIds = + do CtrlVState{..} <- ask + return $ map (pasteId . pasteMeta) $ IxSet.toAscList (Proxy :: Proxy PasteId) pastes + -- | now we need to tell acid-state which functions should be turn into -- acid-state events. $(makeAcidic ''CtrlVState [ 'getPasteById , 'getRecentPastes + , 'getPasteIds , 'insertPaste ]) @@ -152,7 +163,8 @@ | ViewPaste PasteId | NewPaste | CSS - | U_AuthProfile AuthProfileURL + | Authenticate AuthenticateURL + | CtrlVAppJs deriving (Eq, Ord, Read, Show, Data, Typeable) -- | we will just use template haskell to derive the route mapping @@ -175,16 +187,12 @@ -- | 'Acid' holds all the 'AcidState' handles for this site. data Acid = Acid - { acidAuth :: AcidState AuthState - , acidProfile :: AcidState ProfileState - , acidPaste :: AcidState CtrlVState + { acidAuthenticate :: AcidState AuthenticateState + , 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) AuthenticateState where + getAcidState = acidAuthenticate <$> getAcidSt instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) CtrlVState where getAcidState = acidPaste <$> getAcidSt @@ -197,17 +205,41 @@ -- 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 +withAcid :: AcidState AuthenticateState + -> Maybe FilePath -- ^ state directory -> (Acid -> IO a) -- ^ action -> IO a -withAcid mBasePath f = +withAcid authenticateState 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) + f (Acid authenticateState paste) + ------------------------------------------------------------------------------ +-- angular App Controler +------------------------------------------------------------------------------ + +ctrlVAppJs :: JStat +ctrlVAppJs = [jmacro| + { + var ctrlVApp = angular.module('ctrlVApp', [ + 'happstackAuthentication', + 'usernamePassword', + 'openId', + 'ngRoute' + ]); + + ctrlVApp.config(['$routeProvider', + function($routeProvider) { + $routeProvider.when('/resetPassword', + { templateUrl: '/authenticate/authentication-methods/password/partial/reset-password-form', + controller: 'UsernamePasswordCtrl' + }); + }]); + } + |] + +------------------------------------------------------------------------------ -- appTemplate ------------------------------------------------------------------------------ @@ -220,14 +252,33 @@ -> body -- ^ contents of \ tag -> CtrlV Response appTemplate ttl moreHdrs bdy = - do html <- defaultTemplate ttl - <%><% moreHdrs %> - <%> - - + do routeFn <- askRouteFn + html <- + + + <% ttl %> + + + + + + + <% moreHdrs %> + + +
+ + +-- + <% bdy %> +
+ + + +{- <% do mUserId <- join $ liftM2 getUserId getAcidState getAcidState -- Debugging @@ -250,8 +301,7 @@
  • add another auth mode to your profile
    • %> - <% bdy %> - +-} return (toResponse html) -- | This makes it easy to embed a PasteId in an HSP template @@ -264,11 +314,8 @@ 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)) - +instance EmbedAsChild CtrlV' Username where + asChild u = asChild (u ^. unUsername) ------------------------------------------------------------------------------ -- Pages ------------------------------------------------------------------------------ @@ -287,6 +334,7 @@ id + replyto title author date @@ -302,8 +350,11 @@ mkTableRow PasteMeta{..} = <% show $ unPasteId pasteId %> + <% case replyTo of + Nothing -> + (Just pid) -> <% pid %> %> <% title %> - <% nickname %> + <% nickname %> <% pasted %> <% show format %> @@ -324,6 +375,11 @@
    Paste:
    <% pid %>
    + <% case replyTo of + Nothing -> <%> + (Just rid) -> + <%>
    Reply To:
    <% rid %>
    + %>
    Title:
    <% title %>
    Author:
    <% nickname %>
    @@ -345,32 +401,55 @@ 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" () $ + appTemplate "Add a Paste" () $ <%> -

    Add a paste

    - <% reform (form here) "add" success Nothing pasteForm %> +
    +

    You Are Not Logged In

    + +

    If you don't have an account already you can signup:

    + + +

    If you have forgotten your password you can request it to be sent to your email address:

    + + +
    +

    You could also sign in using your Google OpenId:

    + + +
    +
    + +
    +

    Add a paste

    + <% theForm here %> +

    You are logged in. You can Click Here To Logout. Or you can change your password here:

    + + +
    +

    If you are an admin you can edit the realm:

    + +
    + +
    where + theForm :: Route -> CtrlV [CtrlV XML] + theForm here = + do pasteIds <- query GetPasteIds + reform (form here) "add" success Nothing (pasteForm pasteIds) + 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 = +pasteForm :: [PasteId] -> CtrlVForm Paste +pasteForm pasteIds = (fieldset $ ul $ - (,,,) <$> (li $ label title ++> (inputText "" `transformEither` required) <++ errorList) - <*> (li $ label nick ++> (inputText "" `transformEither` required) <++ errorList) + (,,,) <$> (li $ label reply to ++> (select ((PasteId 0,"none") : [(pid, show (unPasteId pid)) | pid <- pasteIds]) (== PasteId 0))) + <*> (li $ label title ++> (inputText "" `transformEither` required) <++ errorList) <*> (li $ label format ++> formatForm) <*> (li $ label
    paste
    ++> errorList ++> (textarea 80 25 "" `transformEither` required)) <* inputSubmit "paste!" @@ -378,12 +457,19 @@ where formatForm = select [(a, show a) | a <- [minBound .. maxBound]] (== PlainText) - toPaste (ttl, nick, fmt, bdy) = - do now <- liftIO getCurrentTime - return $ Right $ + toPaste (rid, ttl, fmt, bdy) = + do now <- liftIO getCurrentTime + as <- getAcidState + mToken <- lift $ getToken as + case mToken of + Nothing -> + return $ Left $ "You must login to post." + (Just (token, _)) -> + return $ Right $ (Paste { pasteMeta = PasteMeta { pasteId = PasteId 0 + , replyTo = case rid of (PasteId 0) -> Nothing ; _ -> Just rid , title = ttl - , nickname = nick + , nickname = token ^. tokenUser ^. username , format = fmt , pasted = now } @@ -398,17 +484,20 @@ ------------------------------------------------------------------------------ -- | the route mapping function -route :: Text -> Route -> CtrlV Response -route baseURL url = +route :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response) + -> Text + -> Route + -> CtrlV Response +route routeAuthenticate _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) + Authenticate authenticateURL -> + lift $ nestURL Authenticate $ + mapRouteT lift $ routeAuthenticate authenticateURL + CtrlVAppJs -> + do ok $ toResponse $ ctrlVAppJs + ViewRecent -> viewRecentPage (ViewPaste pid) -> viewPastePage pid NewPaste -> newPastePage @@ -420,17 +509,37 @@ -- | start the app. listens on port 8000. main :: IO () -main = withAcid Nothing $ \acid -> do +main = do + (cleanup, routeAuthenticate, authenticateState) <- + let authenticateConfig = AuthenticateConfig + { _isAuthAdmin = const $ return True + , _usernameAcceptable = usernamePolicy + , _requireEmail = True + } + passwordConfig = PasswordConfig + { _resetLink = "http://localhost:8000/#resetPassword" + , _domain = "example.org" + , _passwordAcceptable = \t -> + if Text.length t >= 5 + then Nothing + else Just "Must be at least 5 characters." + } + in + initAuthentication Nothing authenticateConfig + [ initPassword passwordConfig + , initOpenId + ] + withAcid authenticateState 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) + (simpleApp id + defaultConf { httpConf = nullConf { + port = appPort + } + } + (AcidUsing acid) + () + ViewRecent + hosturl + (route routeAuthenticate hosturl)) `finally` cleanup diff --git a/examples/ControlVAuth/Setup.hs b/examples/ControlVAuth/Setup.hs --- a/examples/ControlVAuth/Setup.hs +++ b/examples/ControlVAuth/Setup.hs @@ -1,2 +1,11 @@ +#!/usr/bin/env runghc + import Distribution.Simple -main = defaultMain +import Distribution.Simple.Program + +hsx2hsProgram = simpleProgram "hsx2hs" + +main :: IO () +main = defaultMainWithHooks simpleUserHooks { + hookedPrograms = [hsx2hsProgram] + } 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.8 +Version: 0.5.9 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: @@ -41,7 +41,7 @@ Exposed-modules: Happstack.Foundation Build-Depends: base < 5, - acid-state >= 0.7 && < 0.13, + acid-state >= 0.7 && < 0.15, happstack-hsp == 7.3.*, happstack-server >= 7.0 && < 7.5, hsp >= 0.9 && < 0.11, @@ -51,7 +51,7 @@ reform == 0.2.*, reform-happstack == 0.2.*, reform-hsp == 0.2.*, - safecopy >= 0.7 && < 0.9, + safecopy >= 0.7 && < 0.10, text >= 0.11 && < 1.3, web-routes == 0.27.*, web-routes-happstack == 0.23.*,