Cleaned up helpers + docs
This commit is contained in:
parent
e062033942
commit
d385fc48d1
@ -13,6 +13,8 @@
|
||||
--
|
||||
---------------------------------------------------------
|
||||
|
||||
-- | Generation of Atom newsfeeds. See
|
||||
-- <http://en.wikipedia.org/wiki/Atom_(standard)>.
|
||||
module Yesod.Helpers.AtomFeed
|
||||
( AtomFeed (..)
|
||||
, AtomFeedEntry (..)
|
||||
|
||||
@ -20,18 +20,19 @@
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Yesod.Helpers.Auth
|
||||
( redirectLogin
|
||||
, Auth (..)
|
||||
( -- * Subsite
|
||||
Auth (..)
|
||||
, AuthRoutes (..)
|
||||
, siteAuth
|
||||
-- * Settings
|
||||
, YesodAuth (..)
|
||||
, identKey
|
||||
, displayNameKey
|
||||
, Creds (..)
|
||||
, maybeCreds
|
||||
, requireCreds
|
||||
, AuthType (..)
|
||||
, AuthEmailSettings (..)
|
||||
, inMemoryEmailSettings
|
||||
-- * Functions
|
||||
, maybeCreds
|
||||
, requireCreds
|
||||
) where
|
||||
|
||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
@ -71,12 +72,16 @@ class Yesod master => YesodAuth master where
|
||||
stdgen <- newStdGen
|
||||
return $ take 10 $ randomRs ('A', 'Z') stdgen
|
||||
|
||||
-- | Each authentication subsystem (OpenId, Rpxnow, Email) has its own
|
||||
-- settings. If those settings are not present, then relevant handlers will
|
||||
-- simply return a 404.
|
||||
data Auth = Auth
|
||||
{ authIsOpenIdEnabled :: Bool
|
||||
, authRpxnowApiKey :: Maybe String
|
||||
, authEmailSettings :: Maybe AuthEmailSettings
|
||||
}
|
||||
|
||||
-- | Which subsystem authenticated the user.
|
||||
data AuthType = AuthOpenId | AuthRpxnow | AuthEmail
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
@ -86,7 +91,12 @@ type VerUrl = String
|
||||
type EmailId = Integer
|
||||
type SaltedPass = String
|
||||
type VerStatus = Bool
|
||||
|
||||
-- | Data stored in a database for each e-mail address.
|
||||
data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey
|
||||
|
||||
-- | For a sample set of settings for a trivial in-memory database, see
|
||||
-- 'inMemoryEmailSettings'.
|
||||
data AuthEmailSettings = AuthEmailSettings
|
||||
{ addUnverified :: Email -> VerKey -> IO EmailId
|
||||
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()
|
||||
@ -116,6 +126,7 @@ setCreds creds extra = do
|
||||
setSession credsKey $ show creds
|
||||
onLogin creds extra
|
||||
|
||||
-- | Retrieves user credentials, if user is authenticated.
|
||||
maybeCreds :: GHandler sub master (Maybe Creds)
|
||||
maybeCreds = do
|
||||
mcs <- lookupSession credsKey
|
||||
@ -258,22 +269,17 @@ getLogout = do
|
||||
clearSession credsKey
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
|
||||
-- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie
|
||||
-- appropriately.
|
||||
redirectLogin :: YesodAuth master => GHandler sub master a
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
setUltDest'
|
||||
redirect RedirectTemporary $ defaultLoginRoute y
|
||||
|
||||
-- | Retrieve user credentials. If user is not logged in, redirects to the
|
||||
-- 'defaultLoginRoute'. Sets ultimate destination to current route, so user
|
||||
-- should be sent back here after authenticating.
|
||||
requireCreds :: YesodAuth master => GHandler sub master Creds
|
||||
requireCreds = maybeCreds >>= maybe redirectLogin return
|
||||
|
||||
identKey :: String
|
||||
identKey = "IDENTIFIER"
|
||||
|
||||
displayNameKey :: String
|
||||
displayNameKey = "DISPLAY_NAME"
|
||||
requireCreds =
|
||||
maybeCreds >>= maybe redirectLogin return
|
||||
where
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
setUltDest'
|
||||
redirect RedirectTemporary $ defaultLoginRoute y
|
||||
|
||||
getAuthEmailSettings :: GHandler Auth master AuthEmailSettings
|
||||
getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings
|
||||
|
||||
@ -13,6 +13,9 @@
|
||||
--
|
||||
---------------------------------------------------------
|
||||
|
||||
-- | Generates XML sitemap files.
|
||||
--
|
||||
-- See <http://www.sitemaps.org/>.
|
||||
module Yesod.Helpers.Sitemap
|
||||
( sitemap
|
||||
, robots
|
||||
@ -31,6 +34,7 @@ data SitemapChangeFreq = Always
|
||||
| Monthly
|
||||
| Yearly
|
||||
| Never
|
||||
|
||||
showFreq :: SitemapChangeFreq -> String
|
||||
showFreq Always = "always"
|
||||
showFreq Hourly = "hourly"
|
||||
@ -64,6 +68,7 @@ template urls = [$hamlet|
|
||||
sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml
|
||||
sitemap = fmap RepXml . hamletToContent . template
|
||||
|
||||
-- | A basic robots file which just lists the "Sitemap: " line.
|
||||
robots :: Routes sub -- ^ sitemap url
|
||||
-> GHandler sub master RepPlain
|
||||
robots smurl = do
|
||||
|
||||
@ -11,20 +11,23 @@
|
||||
-- Stability : Unstable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Serve static files from a Yesod app.
|
||||
|
||||
-- | Serve static files from a Yesod app.
|
||||
--
|
||||
-- This is most useful for standalone testing. When running on a production
|
||||
-- server (like Apache), just let the server do the static serving.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
-- In fact, in an ideal setup you'll serve your static files from a separate
|
||||
-- domain name to save time on transmitting cookies. In that case, you may wish
|
||||
-- to use 'urlRenderOverride' to redirect requests to this subsite to a
|
||||
-- separate domain name.
|
||||
module Yesod.Helpers.Static
|
||||
( FileLookup
|
||||
, fileLookupDir
|
||||
( -- * Subsite
|
||||
Static (..)
|
||||
, StaticRoutes (..)
|
||||
, siteStatic
|
||||
, StaticRoutes
|
||||
, toStaticRoute
|
||||
, staticArgs
|
||||
, Static
|
||||
-- * Lookup files in filesystem
|
||||
, fileLookupDir
|
||||
) where
|
||||
|
||||
import System.Directory (doesFileExist)
|
||||
@ -32,25 +35,21 @@ import Control.Monad
|
||||
|
||||
import Yesod
|
||||
import Data.List (intercalate)
|
||||
import Network.Wai
|
||||
|
||||
type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))
|
||||
|
||||
data Static = Static FileLookup
|
||||
|
||||
staticArgs :: FileLookup -> Static
|
||||
staticArgs = Static
|
||||
-- | A function for looking up file contents. For serving from the file system,
|
||||
-- see 'fileLookupDir'.
|
||||
data Static = Static (FilePath -> IO (Maybe (Either FilePath Content)))
|
||||
|
||||
$(mkYesodSub "Static" [] [$parseRoutes|
|
||||
/* StaticRoute GET
|
||||
|])
|
||||
|
||||
-- | A 'FileLookup' for files in a directory. Note that this function does not
|
||||
-- check if the requested path does unsafe things, eg expose hidden files. You
|
||||
-- should provide this checking elsewhere.
|
||||
-- | Lookup files in a specific directory.
|
||||
--
|
||||
-- If you are just using this in combination with serveStatic, serveStatic
|
||||
-- provides this checking.
|
||||
-- If you are just using this in combination with the static subsite (you
|
||||
-- probably are), the handler itself checks that no unsafe paths are being
|
||||
-- requested. In particular, no path segments may begin with a single period,
|
||||
-- so hidden files and parent directories are safe.
|
||||
fileLookupDir :: FilePath -> Static
|
||||
fileLookupDir dir = Static $ \fp -> do
|
||||
let fp' = dir ++ '/' : fp
|
||||
@ -59,11 +58,11 @@ fileLookupDir dir = Static $ \fp -> do
|
||||
then return $ Just $ Left fp'
|
||||
else return Nothing
|
||||
|
||||
getStatic :: FileLookup -> [String] -> GHandler sub master [(ContentType, Content)]
|
||||
getStatic fl fp' = do
|
||||
getStaticRoute :: [String]
|
||||
-> GHandler Static master [(ContentType, Content)]
|
||||
getStaticRoute fp' = do
|
||||
Static fl <- getYesodSub
|
||||
when (any isUnsafe fp') notFound
|
||||
wai <- waiRequest
|
||||
when (requestMethod wai /= GET) badMethod
|
||||
let fp = intercalate "/" fp'
|
||||
content <- liftIO $ fl fp
|
||||
case content of
|
||||
@ -74,11 +73,3 @@ getStatic fl fp' = do
|
||||
isUnsafe [] = True
|
||||
isUnsafe ('.':_) = True
|
||||
isUnsafe _ = False
|
||||
|
||||
getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)]
|
||||
getStaticRoute fp = do
|
||||
Static fl <- getYesodSub
|
||||
getStatic fl fp
|
||||
|
||||
toStaticRoute :: [String] -> StaticRoutes
|
||||
toStaticRoute = StaticRoute
|
||||
|
||||
Loading…
Reference in New Issue
Block a user