happstack-foundation 0.5.8 → 0.5.9

raw patch · 5 files changed

+229/−106 lines, 5 filesdep ~acid-statedep ~safecopyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: acid-state, safecopy

API changes (from Hackage documentation)

Files

• examples/ControlV/ControlV.cabal +2/−2
• examples/ControlVAuth/ControlVAuth.cabal +11/−6
• examples/ControlVAuth/Main.hs +203/−94
• examples/ControlVAuth/Setup.hs +10/−1
• happstack-foundation.cabal +3/−3

@@ -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

@@ -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

@@ -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 \<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 routeFn <- askRouteFn+       html <- <html>+                <head>+                 <meta name="viewport" content="width=device-width, initial-scale=1" />+                 <title><% ttl %></title>+                 <script src="https://ajax.googleapis.com/ajax/libs/jquery/1.11.1/jquery.min.js"></script>+                 <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular.min.js"></script>+                 <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular-route.min.js"></script>+                 <script src=(routeFn CtrlVAppJs [])></script>+                 <script src=(routeFn (Authenticate Controllers) [])></script>+                 <link rel="stylesheet" href=CSS type="text/css" media="screen" />+                 <% moreHdrs %>+                </head>+                <body ng-app="ctrlVApp" ng-controller="AuthenticationCtrl">+                 <div ng-controller="UsernamePasswordCtrl">+                  <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>+--                 <up-login-inline />+                  <% bdy %>+                 </div>+                </body>+               </html>++{-                    <% do mUserId <- join $ liftM2 getUserId getAcidState getAcidState                           -- Debugging@@ -250,8 +301,7 @@                                 <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@@ -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 @@                   <thead>                    <tr>                     <th>id</th>+                    <th>replyto</th>                     <th>title</th>                     <th>author</th>                     <th>date</th>@@ -302,8 +350,11 @@       mkTableRow PasteMeta{..} =           <tr>            <td><a href=(ViewPaste pasteId)><% show $ unPasteId pasteId %></a></td>+           <td><% case replyTo of+                    Nothing -> <span/>+                    (Just pid) -> <a href=(ViewPaste pid)><% pid %></a> %></td>            <td><a href=(ViewPaste pasteId)><% title       %></a></td>-           <td><% nickname    %></td>+           <td><% nickname %></td>            <td><% pasted      %></td>            <td><% show format %></td>           </tr>@@ -324,6 +375,11 @@                     <div class="paste">                      <dl class="paste-header">                       <dt>Paste:</dt><dd><a href=(ViewPaste pid)><% pid %></a></dd>+                      <% case replyTo of+                           Nothing -> <%><span /></%>+                           (Just rid) ->+                               <%><dt>Reply To:</dt><dd><a href=(ViewPaste rid)><% rid %></a></dd></%>+                        %>                       <dt>Title:</dt><dd><% title %></dd>                       <dt>Author:</dt><dd><% nickname %></dd>                      </dl>@@ -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" () $-              <%>-                <h1>You Are Not Logged In</h1>-              </%>-          (Just uid) ->-            appTemplate "Add a Paste" () $+       appTemplate "Add a Paste" () $               <%>-                <h1>Add a paste</h1>-                <% reform (form here) "add" success Nothing pasteForm %>+                <div up-authenticated=False>+                 <h1>You Are Not Logged In</h1>+                 <up-login-inline />+                 <p>If you don't have an account already you can signup:</p>+                 <up-signup-password />++                 <p>If you have forgotten your password you can request it to be sent to your email address:</p>+                 <up-request-reset-password />++                 <div ng-controller="OpenIdCtrl">+                  <p>You could also sign in using your Google OpenId:</p>+                  <openid-google />+                  <openid-yahoo />+                 </div>+                </div>++                <div up-authenticated=True>+                 <h1>Add a paste</h1>+                 <% theForm here %>+                 <p>You are logged in. You can <a ng-click="logout()" href="">Click Here To Logout</a>. Or you can change your password here:</p>+                 <up-change-password />++                 <div ng-controller="OpenIdCtrl" ng-hide="!claims.authAdmin">+                  <p>If you are an admin you can edit the realm:</p>+                  <openid-realm />+                 </div>++                </div>               </%>     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 <span>title</span>  ++> (inputText "" `transformEither` required) <++ errorList)-                <*> (li $ label <span>nick</span>   ++> (inputText "" `transformEither` required) <++ errorList)+          (,,,) <$> (li $ label <span>reply to</span> ++> (select ((PasteId 0,"none") : [(pid, show (unPasteId pid)) | pid <- pasteIds]) (== PasteId 0)))+                <*> (li $ label <span>title</span>  ++> (inputText "" `transformEither` required) <++ errorList)                 <*> (li $ label <span>format</span> ++> formatForm)                 <*> (li $ label <div>paste</div>    ++> 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

@@ -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]+       }

@@ -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.*,