From 9c4cd573b46e640eda6248c2e727df2f9a0ee0e0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 14 Mar 2013 09:28:51 +0200 Subject: [PATCH] Everything compiles --- yesod-auth/Yesod/Auth.hs | 50 ++++---- yesod-auth/Yesod/Auth/BrowserId.hs | 15 +-- yesod-auth/Yesod/Auth/Dummy.hs | 5 +- yesod-auth/Yesod/Auth/Email.hs | 83 ++++++------ yesod-auth/Yesod/Auth/GoogleEmail.hs | 7 +- yesod-auth/Yesod/Auth/HashDB.hs | 27 ++-- yesod-auth/Yesod/Auth/OpenId.hs | 15 +-- yesod-auth/Yesod/Auth/Rpxnow.hs | 10 +- yesod-core/Yesod/Core.hs | 4 + yesod-core/Yesod/Core/Handler.hs | 4 +- yesod-core/Yesod/Core/Widget.hs | 11 +- yesod-form/Yesod/Form/Class.hs | 6 +- yesod-form/Yesod/Form/Fields.hs | 101 ++++++++------- yesod-form/Yesod/Form/Functions.hs | 182 +++++++++++++-------------- yesod-form/Yesod/Form/Input.hs | 22 ++-- yesod-form/Yesod/Form/Jquery.hs | 12 +- yesod-form/Yesod/Form/MassInput.hs | 21 ++-- yesod-form/Yesod/Form/Nic.hs | 8 +- yesod-form/Yesod/Form/Types.hs | 39 +++--- yesod-newsfeed/Yesod/AtomFeed.hs | 12 +- yesod-newsfeed/Yesod/Feed.hs | 2 +- yesod-newsfeed/Yesod/RssFeed.hs | 8 +- yesod-persistent/Yesod/Persist.hs | 10 +- yesod-sitemap/Yesod/Sitemap.hs | 9 +- yesod-static/Yesod/Static.hs | 2 +- yesod/Yesod/Default/Util.hs | 2 +- 26 files changed, 352 insertions(+), 315 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 59003582..7f6f0111 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -25,6 +25,8 @@ module Yesod.Auth , requireAuth -- * Exception , AuthException (..) + -- * Helper + , AuthHandler ) where import Control.Monad (when) @@ -39,8 +41,6 @@ import qualified Data.Text as T import qualified Data.HashMap.Lazy as Map import Network.HTTP.Conduit (Manager) -import Language.Haskell.TH.Syntax hiding (lift) - import qualified Network.Wai as W import Text.Hamlet (shamlet) @@ -51,10 +51,11 @@ import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception) +import Control.Monad.Trans.Class type AuthRoute = Route Auth -type AuthHandler master a = YesodAuth master => HandlerT Auth (GHandler master) a +type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a type Method = Text type Piece = Text @@ -62,7 +63,7 @@ type Piece = Text data AuthPlugin master = AuthPlugin { apName :: Text , apDispatch :: Method -> [Piece] -> AuthHandler master () - , apLogin :: (Route Auth -> Text) -> GWidget master () + , apLogin :: (Route Auth -> Route master) -> WidgetT master IO () } getAuth :: a -> Auth @@ -87,7 +88,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage logoutDest :: master -> Route master -- | Determine the ID associated with the set of credentials. - getAuthId :: Creds master -> GHandler master (Maybe (AuthId master)) + getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master)) -- | Which authentication backends to use. authPlugins :: master -> [AuthPlugin master] @@ -95,16 +96,17 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- | What to show on the login page. loginHandler :: AuthHandler master RepHtml loginHandler = do - render <- getUrlRender + tp <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.LoginTitle - master <- lift getYesod - mapM_ (flip apLogin render) (authPlugins master) + master <- getYesod + mapM_ (flip apLogin tp) (authPlugins master) -- | Used for i18n of messages provided by this package. renderAuthMessage :: master -> [Text] -- ^ languages - -> AuthMessage -> Text + -> AuthMessage + -> Text renderAuthMessage _ _ = defaultMessage -- | After login and logout, redirect to the referring page, instead of @@ -120,11 +122,11 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- | Called on a successful login. By default, calls -- @setMessageI NowLoggedIn@. - onLogin :: GHandler master () + onLogin :: HandlerT master IO () onLogin = setMessageI Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: GHandler master () + onLogout :: HandlerT master IO () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -136,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- other than a browser. -- -- Since 1.1.2 - maybeAuthId :: GHandler master (Maybe (AuthId master)) + maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId credsKey :: Text @@ -146,15 +148,15 @@ credsKey = "_ID" -- -- Since 1.1.2 defaultMaybeAuthId :: YesodAuth master - => GHandler master (Maybe (AuthId master)) + => HandlerT master IO (Maybe (AuthId master)) defaultMaybeAuthId = do ms <- lookupSession credsKey case ms of Nothing -> return Nothing Just s -> return $ fromPathPiece s -setCreds :: Bool -> Creds master -> AuthHandler master () -setCreds doRedirects creds = lift $ do +setCreds :: YesodAuth master => Bool -> Creds master -> HandlerT master IO () +setCreds doRedirects creds = do y <- getYesod maid <- getAuthId creds case maid of @@ -233,14 +235,14 @@ handlePluginR plugin pieces = do ap:_ -> apDispatch ap method pieces maybeAuth :: ( YesodAuth master - , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val , b ~ YesodPersistBackend master , Key val ~ AuthId master - , PersistStore (b (GHandler master)) + , PersistStore (b (HandlerT master IO)) , PersistEntity val , YesodPersist master , Typeable val - ) => GHandler master (Maybe (Entity val)) + ) => HandlerT master IO (Maybe (Entity val)) maybeAuth = runMaybeT $ do aid <- MaybeT $ maybeAuthId a <- MaybeT @@ -254,21 +256,21 @@ maybeAuth = runMaybeT $ do newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } deriving Typeable -requireAuthId :: YesodAuth master => GHandler master (AuthId master) +requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master) requireAuthId = maybeAuthId >>= maybe redirectLogin return requireAuth :: ( YesodAuth master , b ~ YesodPersistBackend master - , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val , Key val ~ AuthId master - , PersistStore (b (GHandler master)) + , PersistStore (b (HandlerT master IO)) , PersistEntity val , YesodPersist master , Typeable val - ) => GHandler master (Entity val) + ) => HandlerT master IO (Entity val) requireAuth = maybeAuth >>= maybe redirectLogin return -redirectLogin :: Yesod master => GHandler master a +redirectLogin :: Yesod master => HandlerT master IO a redirectLogin = do y <- getYesod setUltDestCurrent @@ -284,5 +286,5 @@ data AuthException = InvalidBrowserIDAssertion deriving (Show, Typeable) instance Exception AuthException -instance YesodAuth master => YesodSubDispatch Auth (GHandler master) where +instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 95e12467..c4f561eb 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -22,6 +22,7 @@ import Data.Aeson (toJSON) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) import Data.ByteString (ByteString) +import Control.Monad.Trans.Class pid :: Text pid = "browserid" @@ -59,7 +60,7 @@ helper maudience = AuthPlugin memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion - Just email -> setCreds True Creds + Just email -> lift $ setCreds True Creds { credsPlugin = pid , credsIdent = email , credsExtra = [] @@ -73,7 +74,7 @@ helper maudience = AuthPlugin , apLogin = \toMaster -> do onclick <- createOnClick toMaster - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" + autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius| #{rawJS onclick}(); |] @@ -82,7 +83,7 @@ helper maudience = AuthPlugin $newline never

- + |] } where @@ -91,18 +92,18 @@ $newline never -- | Generates a function to handle on-click events, and returns that function -- name. -createOnClick :: (Route Auth -> Text) -> GWidget master Text +createOnClick :: (Route Auth -> Route master) -> WidgetT master IO Text createOnClick toMaster = do addScriptRemote browserIdJs onclick <- newIdent render <- getUrlRender - let login = toJSON $ getPath $ toMaster LoginR + let login = toJSON $ getPath $ render $ toMaster LoginR toWidget [julius| function #{rawJS onclick}() { navigator.id.watch({ onlogin: function (assertion) { if (assertion) { - document.location = #{toJSON $ toMaster complete} + "/" + assertion; + document.location = "@{toMaster complete}" + "/" + assertion; } }, onlogout: function () {} @@ -113,7 +114,7 @@ createOnClick toMaster = do } |] - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" + autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius|#{rawJS onclick}();|] return onclick where diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index 26000be2..96d8aa96 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -11,6 +11,7 @@ import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) import Text.Hamlet (hamlet) import Yesod.Core +import Control.Monad.Trans.Class authDummy :: YesodAuth m => AuthPlugin m authDummy = @@ -18,13 +19,13 @@ authDummy = where dispatch "POST" [] = do ident <- lift $ runInputPost $ ireq textField "ident" - setCreds True $ Creds "dummy" ident [] + lift $ setCreds True $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = toWidget [hamlet| $newline never -

+ Your new identifier is: # diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index caa8ebd6..456ce65d 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -27,6 +27,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text (Text) import qualified Crypto.PasswordStore as PS import qualified Data.Text.Encoding as DTE +import Control.Monad.Trans.Class import Yesod.Form import Yesod.Core @@ -55,21 +56,21 @@ data EmailCreds m = EmailCreds , emailCredsVerkey :: Maybe VerKey } -class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where - type AuthEmailId m +class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where + type AuthEmailId site - addUnverified :: Email -> VerKey -> GHandler m (AuthEmailId m) - sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler m () - getVerifyKey :: AuthEmailId m -> GHandler m (Maybe VerKey) - setVerifyKey :: AuthEmailId m -> VerKey -> GHandler m () - verifyAccount :: AuthEmailId m -> GHandler m (Maybe (AuthId m)) - getPassword :: AuthId m -> GHandler m (Maybe SaltedPass) - setPassword :: AuthId m -> SaltedPass -> GHandler m () - getEmailCreds :: Email -> GHandler m (Maybe (EmailCreds m)) - getEmail :: AuthEmailId m -> GHandler m (Maybe Email) + addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site) + sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () + getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) + setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () + verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) + getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) + setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () + getEmailCreds :: Email -> HandlerT site IO (Maybe (EmailCreds site)) + getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) -- | Generate a random alphanumeric string. - randomKey :: m -> IO Text + randomKey :: site -> IO Text randomKey _ = do stdgen <- newStdGen return $ TS.pack $ fst $ randomString 10 stdgen @@ -79,7 +80,7 @@ authEmail = AuthPlugin "email" dispatch $ \tm -> [whamlet| $newline never - +
_{Msg.Email} @@ -92,7 +93,7 @@ $newline never
- I don't have an account + I don't have an account |] where dispatch "GET" ["register"] = getRegisterR >>= sendResponse @@ -106,21 +107,21 @@ $newline never dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch _ _ = notFound -getRegisterR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml +getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml getRegisterR = do email <- newIdent - mrender <- getMessageRender - defaultLayoutT $ do - setTitle $ toHtml $ mrender Msg.RegisterLong + tp <- getRouteToParent + lift $ defaultLayout $ do + setTitleI Msg.RegisterLong [whamlet| -

#{mrender Msg.EnterEmail} - -

_{Msg.EnterEmail} + +

_{Msg.InvalidKey}|] -postLoginR :: YesodAuthEmail master => HandlerT Auth (GHandler master) () +postLoginR :: YesodAuthEmail master => AuthHandler master () postLoginR = do (email, pass) <- lift $ runInputPost $ (,) <$> ireq emailField "email" @@ -184,46 +184,45 @@ postLoginR = do _ -> return Nothing case maid of Just _aid -> - setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? + lift $ setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? Nothing -> do - mrender <- lift getMessageRender - setMessage $ toHtml $ mrender Msg.InvalidEmailPass + lift $ setMessageI Msg.InvalidEmailPass redirect LoginR -getPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml +getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml getPasswordR = do maid <- lift maybeAuthId pass1 <- newIdent pass2 <- newIdent - mrender <- lift getMessageRender case maid of Just _ -> return () Nothing -> do - setMessage $ toHtml $ mrender Msg.BadSetPass + lift $ setMessageI Msg.BadSetPass redirect LoginR - defaultLayoutT $ do - setTitle $ toHtml $ mrender Msg.SetPassTitle -- FIXME make setTitleI more intelligent + tp <- getRouteToParent + lift $ defaultLayout $ do + setTitleI Msg.SetPassTitle [whamlet| $newline never -

#{mrender Msg.SetPass} - +

_{Msg.SetPass} +
-
-
- + |] -postPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) () +postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) () postPasswordR = do (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new" diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs index 5ed1003a..ee11340d 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import qualified Yesod.Auth.Message as Msg import qualified Data.Text as T import Control.Exception.Lifted (try, SomeException) +import Control.Monad.Trans.Class pid :: Text pid = "googleemail" @@ -40,7 +41,7 @@ authGoogleEmail = where complete = PluginR pid ["complete"] login tm = - [whamlet|_{Msg.LoginGoogle}|] + [whamlet|_{Msg.LoginGoogle}|] dispatch "GET" ["forward"] = do render <- getUrlRender let complete' = render complete @@ -70,7 +71,7 @@ authGoogleEmail = completeHelper posts dispatch _ _ = notFound -completeHelper :: YesodAuth m => [(Text, Text)] -> HandlerT Auth (GHandler m) () +completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper gets' = do master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) @@ -81,7 +82,7 @@ completeHelper gets' = do let OpenId.Identifier ident = OpenId.oirOpLocal oir memail <- lookupGetParam "openid.ext1.value.email" case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of - (Just email, True) -> setCreds True $ Creds pid email [] + (Just email, True) -> lift $ setCreds True $ Creds pid email [] (_, False) -> do setMessage "Only Google login is supported" redirect LoginR diff --git a/yesod-auth/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs index 66f9746b..4c268e64 100644 --- a/yesod-auth/Yesod/Auth/HashDB.hs +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -81,6 +81,7 @@ import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM,liftM) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) import qualified Data.ByteString.Lazy.Char8 as BS (pack) import Data.Digest.Pure.SHA (sha1, showDigest) @@ -134,14 +135,14 @@ setPassword pwd u = do salt <- randomSalt -- the database values. validateUser :: ( YesodPersist yesod , b ~ YesodPersistBackend yesod - , PersistMonadBackend (b (GHandler yesod)) ~ PersistEntityBackend user - , PersistUnique (b (GHandler yesod)) + , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user + , PersistUnique (b (HandlerT yesod IO)) , PersistEntity user , HashDBUser user ) => Unique user -- ^ User unique identifier -> Text -- ^ Password in plaint-text - -> GHandler yesod Bool + -> HandlerT yesod IO Bool validateUser userID passwd = do -- Checks that hash and password match let validate u = do hash <- userPasswordHash u @@ -161,11 +162,11 @@ login = PluginR "hashdb" ["login"] postLoginR :: ( YesodAuth y, YesodPersist y , HashDBUser user, PersistEntity user , b ~ YesodPersistBackend y - , PersistMonadBackend (b (GHandler y)) ~ PersistEntityBackend user - , PersistUnique (b (GHandler y)) + , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user + , PersistUnique (b (HandlerT y IO)) ) => (Text -> Maybe (Unique user)) - -> HandlerT Auth (GHandler y) () + -> HandlerT Auth (HandlerT y IO) () postLoginR uniq = do (mu,mp) <- lift $ runInputPost $ (,) <$> iopt textField "username" @@ -174,7 +175,7 @@ postLoginR uniq = do isValid <- lift $ fromMaybe (return False) (validateUser <$> (uniq =<< mu) <*> mp) if isValid - then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] + then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] else do setMessage "Invalid username/password" redirect LoginR @@ -185,13 +186,13 @@ getAuthIdHashDB :: ( YesodAuth master, YesodPersist master , HashDBUser user, PersistEntity user , Key user ~ AuthId master , b ~ YesodPersistBackend master - , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend user - , PersistUnique (b (GHandler master)) + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user + , PersistUnique (b (HandlerT master IO)) ) => (AuthRoute -> Route master) -- ^ your site's Auth Route -> (Text -> Maybe (Unique user)) -- ^ gets user ID -> Creds master -- ^ the creds argument - -> GHandler master (Maybe (AuthId master)) + -> HandlerT master IO (Maybe (AuthId master)) getAuthIdHashDB authR uniq creds = do muid <- maybeAuthId case muid of @@ -214,8 +215,8 @@ authHashDB :: ( YesodAuth m, YesodPersist m , HashDBUser user , PersistEntity user , b ~ YesodPersistBackend m - , PersistMonadBackend (b (GHandler m)) ~ PersistEntityBackend user - , PersistUnique (b (GHandler m))) + , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user + , PersistUnique (b (HandlerT m IO))) => (Text -> Maybe (Unique user)) -> AuthPlugin m authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet| $newline never @@ -223,7 +224,7 @@ $newline never

Login
- +
Username: diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index 3e8c2c32..21a00e87 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -21,6 +21,7 @@ import Data.Text (Text, isPrefixOf) import qualified Yesod.Auth.Message as Msg import Control.Exception.Lifted (SomeException, try) import Data.Maybe (fromMaybe) +import Control.Monad.Trans.Class forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] @@ -37,7 +38,7 @@ authOpenId idType extensionFields = complete = PluginR "openid" ["complete"] name = "openid_identifier" login tm = do - ident <- lift newIdent + ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the -- code, but it shouldn't be necessary let y :: a -> [(Text, Text)] -> Text @@ -48,13 +49,13 @@ authOpenId idType extensionFields = |] $ x `asTypeOf` y) [whamlet| $newline never - +