Converted auth helper to subsite

Yesod/Hamlet.hs

@@ -45,6 +45,12 @@ hamletToRepHtml h = do
     c <- hamletToContent h
     return $ RepHtml c
 
+-- FIXME some type of JSON combined output...
+--hamletToRepHtmlJson :: x
+--                    -> (x -> Hamlet (Routes y) IO ())
+--                    -> (x -> Json)
+--                    -> Handler y RepHtmlJson
+
 instance Monad m => ConvertSuccess String (Hamlet url m ()) where
     convertSuccess = outputHtml . Unencoded . cs
 instance Monad m

Yesod/Handler.hs

@@ -23,7 +23,9 @@ module Yesod.Handler
       Handler
     , getYesod
     , getUrlRender
+    , getRoute
     , runHandler
+    , runHandler'
     , liftIO
     , YesodApp (..)
     , Routes
@@ -59,7 +61,12 @@ import Data.Convertible.Text (cs)
 
 type family Routes y
 
-data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String)
+data HandlerData yesod = HandlerData
+    { handlerRequest :: Request
+    , handlerYesod :: yesod
+    , handlerRoute :: Maybe (Routes yesod)
+    , handlerRender :: (Routes yesod -> String)
+    }
 
 newtype YesodApp = YesodApp
     { unYesodApp
@@ -100,22 +107,37 @@ instance MonadIO (Handler yesod) where
 instance Failure ErrorResponse (Handler yesod) where
     failure e = Handler $ \_ -> return ([], HCError e)
 instance RequestReader (Handler yesod) where
-    getRequest = Handler $ \(HandlerData rr _ _)
+    getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r)
-                        -> return ([], HCContent rr)
 
 getYesod :: Handler yesod yesod
-getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod)
+getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r)
 
 getUrlRender :: Handler yesod (Routes yesod -> String)
-getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r)
+getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r)
 
-runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp
+getRoute :: Handler yesod (Maybe (Routes yesod))
-runHandler handler y render = YesodApp $ \eh rr cts -> do
+getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r)
+
+runHandler' :: HasReps c
+            => Handler yesod c
+            -> yesod
+            -> Routes yesod
+            -> (Routes yesod -> String)
+            -> YesodApp
+runHandler' handler y route render = runHandler handler y (Just route) render
+
+runHandler :: HasReps c
+           => Handler yesod c
+           -> yesod
+           -> Maybe (Routes yesod)
+           -> (Routes yesod -> String)
+           -> YesodApp
+runHandler handler y route render = YesodApp $ \eh rr cts -> do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
     (headers, contents) <- Control.Exception.catch
-        (unHandler handler $ HandlerData rr y render)
+        (unHandler handler $ HandlerData rr y route render)
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
             Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts

Yesod/Helpers/Auth.hs

@@ -2,6 +2,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExistentialQuantification #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -16,16 +19,14 @@
 --
 ---------------------------------------------------------
 module Yesod.Helpers.Auth
-    ( authHandler
+    ( maybeIdentifier
-    , YesodAuth (..)
-    , maybeIdentifier
     , authIdentifier
     , displayName
     , redirectLogin
+    , Auth (..)
+    , siteAuthRoutes
     ) where
 
--- FIXME write as subsite
-
 import Web.Encodings
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import qualified Web.Authenticate.OpenId as OpenId
@@ -35,6 +36,7 @@ import Data.Convertible.Text
 
 import Control.Monad.Attempt
 import qualified Data.ByteString.Char8 as B8
+import Data.Maybe
 
 import qualified Network.Wai as W
 import Data.Typeable (Typeable)
@@ -43,79 +45,49 @@ import Control.Applicative ((<$>))
 
 -- FIXME check referer header to determine destination
 
-class Yesod a => YesodAuth a where
+data LoginType = OpenId | Rpxnow
-    -- | The following breaks DRY, but I cannot think of a better solution
-    -- right now.
-    --
-    -- The root relative to the application root. Should not begin with a slash
-    -- and should end with one.
-    authRoot :: a -> String
-    authRoot _ = "auth/"
 
-    -- | Absolute path to the default login path.
+data Auth = forall y. Yesod y => Auth
-    defaultLoginPath :: a -> String
+    { defaultDest :: String
-    defaultLoginPath a = approot a ++ authRoot a ++ "openid/"
+    , onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth ()
+    , rpxnowApiKey :: Maybe String
+    , defaultLoginType :: LoginType
+    , parentYesod :: y
+    }
 
-    rpxnowApiKey :: a -> Maybe String
+$(mkYesod "Auth" [$parseRoutes|
-    rpxnowApiKey _ = Nothing
+/check                 Check              GET
-
+/logout                Logout             GET
-    onRpxnowLogin :: Rpxnow.Identifier -> Handler a ()
+/openid                OpenIdR            GET
-    onRpxnowLogin _ = return ()
+/openid/forward        OpenIdForward      GET
-
+/openid/complete       OpenIdComplete     GET
-getFullAuthRoot :: YesodAuth y => Handler y String
+/login/rpxnow          RpxnowR
-getFullAuthRoot = do
+|])
-    y <- getYesod
-    ar <- getApproot
-    return $ ar ++ authRoot y
-
-data AuthResource =
-    Check
-    | Logout
-    | Openid
-    | OpenidForward
-    | OpenidComplete
-    | LoginRpxnow
-    deriving (Show, Eq, Enum, Bounded)
-
-rc :: HasReps x => Handler y x -> Handler y ChooseRep
-rc = fmap chooseRep
-
-authHandler :: YesodAuth y => W.Method -> [String] -> Handler y ChooseRep
-authHandler W.GET ["check"] = rc authCheck
-authHandler W.GET ["logout"] = rc authLogout
-authHandler W.GET ["openid"] = rc authOpenidForm
-authHandler W.GET ["openid", "forward"] = rc authOpenidForward
-authHandler W.GET ["openid", "complete"] = rc authOpenidComplete
--- two different versions of RPX protocol apparently, so just accepting all
--- verbs
-authHandler _ ["login", "rpxnow"] = rc rpxnowLogin
-authHandler _ _ = notFound
-
--- FIXME data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
-{- FIXME
-instance ConvertSuccess OIDFormReq Html where
-    convertSuccess (OIDFormReq Nothing _) = cs ""
-    convertSuccess (OIDFormReq (Just s) _) =
-        Tag "p" [("class", "message")] $ cs s
--}
 
 data ExpectedSingleParam = ExpectedSingleParam
     deriving (Show, Typeable)
 instance Exception ExpectedSingleParam
 
-authOpenidForm :: Yesod y => Handler y ChooseRep
+getOpenIdR :: Handler Auth RepHtml
-authOpenidForm = do
+getOpenIdR = do
     rr <- getRequest
     case getParams rr "dest" of
         [] -> return ()
         (x:_) -> addCookie destCookieTimeout destCookieName x
-    let html = template (getParams rr "message")
+    (Auth _ _ _ _ y) <- getYesod
-    simpleApplyLayout "Log in via OpenID" html
+    let html = template (getParams rr "message", id)
+    let pc = PageContent
+                { pageTitle = cs "Log in via OpenID"
+                , pageHead = return ()
+                , pageBody = html
+                }
+    content <- hamletToContent $ applyLayout y pc rr
+    return $ RepHtml content
   where
-    urlForward _ = error "FIXME urlForward"
+    urlForward (_, wrapper) = wrapper OpenIdForward
-    hasMessage = not . null
+    hasMessage = not . null . fst
-    message [] = cs ""
+    message ([], _) = cs ""
-    message (m:_) = cs m
+    message (m:_, _) = cs m
     template = [$hamlet|
 $if hasMessage
     %p.message $message$
@@ -125,14 +97,14 @@ $if hasMessage
     %input!type=submit!value=Login
 |]
 
-authOpenidForward :: YesodAuth y => Handler y ()
+getOpenIdForward :: Handler Auth ()
-authOpenidForward = do
+getOpenIdForward = do
     rr <- getRequest
     oid <- case getParams rr "openid" of
             [x] -> return x
             _ -> invalidArgs [("openid", show ExpectedSingleParam)]
-    authroot <- getFullAuthRoot
+    render <- getUrlRender
-    let complete = authroot ++ "/openid/complete/"
+    let complete = render OpenIdComplete
     res <- runAttemptT $ OpenId.getForwardUrl oid complete
     attempt
       (\err -> redirect RedirectTemporary
@@ -140,8 +112,8 @@ authOpenidForward = do
       (redirect RedirectTemporary)
       res
 
-authOpenidComplete :: Yesod y => Handler y ()
+getOpenIdComplete :: Handler Auth ()
-authOpenidComplete = do
+getOpenIdComplete = do
     rr <- getRequest
     let gets' = reqGetParams rr
     res <- runAttemptT $ OpenId.authenticate gets'
@@ -149,15 +121,14 @@ authOpenidComplete = do
                              $ "/auth/openid/?message="
                             ++ encodeUrl (show err)
     let onSuccess (OpenId.Identifier ident) = do
-        ar <- getApproot
+        y <- getYesod
         header authCookieName ident
-        redirectToDest RedirectTemporary ar
+        redirectToDest RedirectTemporary $ defaultDest y
     attempt onFailure onSuccess res
 
-rpxnowLogin :: YesodAuth y => Handler y ()
+handleRpxnowR :: Handler Auth ()
-rpxnowLogin = do
+handleRpxnowR = do
     ay <- getYesod
-    let ar = approot ay
     apiKey <- case rpxnowApiKey ay of
                 Just x -> return x
                 Nothing -> notFound
@@ -168,13 +139,14 @@ rpxnowLogin = do
                     (x:_) -> x
     let dest = case pp "dest" of
                 [] -> case getParams rr "dest" of
-                        [] -> ar
+                        [] -> defaultDest ay
-                        ("":_) -> ar
+                        ("":_) -> defaultDest ay
                         (('#':rest):_) -> rest
                         (s:_) -> s
                 (d:_) -> d
     ident <- liftIO $ Rpxnow.authenticate apiKey token
-    onRpxnowLogin ident
+    auth <- getYesod
+    onRpxnowLogin auth ident
     header authCookieName $ Rpxnow.identifier ident
     header authDisplayName $ getDisplayName ident
     redirectToDest RedirectTemporary dest
@@ -192,22 +164,25 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
                         Nothing -> helper xs
                         Just y -> y
 
-authCheck :: Yesod y => Handler y ChooseRep
+getCheck :: Handler Auth RepHtml
-authCheck = do
+getCheck = do
-    _ident <- maybeIdentifier
+    ident <- maybeIdentifier
-    _dn <- displayName
+    dn <- displayName
-    error "FIXME applyLayoutJson"
+    -- FIXME applyLayoutJson
-    {-
+    hamletToRepHtml $ [$hamlet|
-    applyLayoutJson "Authentication Status" $ cs
+%h1 Authentication Status
-        [ ("identifier", fromMaybe "" ident)
+%dl
-        , ("displayName", fromMaybe "" dn)
+    %dt identifier
-        ]
+    %dd $fst$
-    -}
+    %dt displayName
+    %dd $snd$
+|] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
 
-authLogout :: YesodAuth y => Handler y ()
+getLogout :: Handler Auth ()
-authLogout = do
+getLogout = do
+    y <- getYesod
     deleteCookie authCookieName
-    getApproot >>= redirectToDest RedirectTemporary
+    redirectToDest RedirectTemporary $ defaultDest y
 
 -- | Gets the identifier for a user if available.
 maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
@@ -223,18 +198,22 @@ displayName = do
 
 -- | Gets the identifier for a user. If user is not logged in, redirects them
 -- to the login page.
-authIdentifier :: YesodAuth y => Handler y String
+authIdentifier :: Handler Auth String
 authIdentifier = maybeIdentifier >>= maybe redirectLogin return
 
 -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie
 -- appropriately.
-redirectLogin :: YesodAuth y => Handler y a
+redirectLogin :: Handler Auth a
-redirectLogin =
+redirectLogin = do
-    defaultLoginPath `fmap` getYesod >>= redirectSetDest RedirectTemporary
+    y <- getYesod
+    let r = case defaultLoginType y of
+                OpenId -> OpenIdR
+                Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page?
+    redirectSetDest RedirectTemporary r
 
 -- | Determinge the path requested by the user (ie, the path info). This
 -- includes the query string.
-requestPath :: (Functor m, Monad m, RequestReader m) => m String
+requestPath :: (Functor m, Monad m, RequestReader m) => m String --FIXME unused
 requestPath = do
     env <- waiRequest
     let q = case B8.unpack $ W.queryString env of
@@ -248,13 +227,18 @@ requestPath = do
 
 -- | Redirect to the given URL, and set a cookie with the current URL so the
 -- user will ultimately be sent back here.
-redirectSetDest :: Yesod y => RedirectType -> String -> Handler y a
+redirectSetDest :: RedirectType
+                -> Routes y -- ^ redirect page
+                -> Handler y a
 redirectSetDest rt dest = do
-    ar <- getApproot
+    ur <- getUrlRender
-    rp <- requestPath
+    curr <- getRoute
-    let curr = ar ++ rp
+    let curr' = case curr of
-    addCookie destCookieTimeout destCookieName curr
+                    Just x -> ur x
-    redirect rt dest
+                    Nothing -> "/" -- should never happen anyway
+        dest' = ur dest
+    addCookie destCookieTimeout destCookieName curr'
+    redirect rt dest'
 
 -- | Read the 'destCookieName' cookie and redirect to this destination. If the
 -- cookie is missing, then use the default path provided.

Yesod/Resource.hs

@@ -20,6 +20,6 @@ mkYesod name res = do
     decs <- createRoutes (name ++ "Routes")
                          ''YesodApp
                          name'
-                         "runHandler"
+                         "runHandler'"
                          res
     return $ tySyn : yes : decs

Yesod/Yesod.hs

@@ -55,9 +55,9 @@ class YesodSite a => Yesod a where
 
     -- | Applies some form of layout to <title> and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit.
     applyLayout :: a
-                -> PageContent (Routes a)
+                -> PageContent url -- FIXME not so good, should be Routes y
                 -> Request
-                -> Hamlet (Routes a) IO ()
+                -> Hamlet url IO ()
     applyLayout _ p _ = [$hamlet|
 !!!
 %html
@@ -159,10 +159,11 @@ toWaiApp' y resource session env = do
     onRequest y rr
     print pathSegments
     let ya = case eurl of
-                Left _ -> runHandler (errorHandler y NotFound) y render
+                Left _ -> runHandler (errorHandler y NotFound) y Nothing render
                 Right url -> handleSite site render url method
                                         (badMethod method) y
-    let eh er = runHandler (errorHandler y er) y render
+    let url' = either (const Nothing) Just eurl
+    let eh er = runHandler (errorHandler y er) y url' render
     unYesodApp ya eh rr types >>= responseToWaiResponse
 
 cleanupSegments :: [B.ByteString] -> [String]