From 3c5637dc6df65ea594ac5ff22d8f0b264a793547 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 9 Apr 2014 14:38:54 +0300 Subject: [PATCH] Authentication system --- Application.hs | 25 ++++++- Data/Slug.hs | 88 +++++++++++++++++++++++++ Foundation.hs | 85 ++++++++++++++++++++---- Handler/Email.hs | 14 ++++ Handler/Home.hs | 24 +------ Handler/Profile.hs | 30 +++++++++ Handler/ResetToken.hs | 12 ++++ Import.hs | 1 + Model.hs | 1 + config/models | 15 +++-- config/routes | 5 +- stackage-server.cabal | 16 +++++ templates/default-layout-wrapper.hamlet | 5 +- templates/default-layout.hamlet | 13 +++- templates/profile.hamlet | 28 ++++++++ templates/profile.lucius | 3 + test/Data/SlugSpec.hs | 22 +++++++ test/main.hs | 3 + 18 files changed, 342 insertions(+), 48 deletions(-) create mode 100644 Data/Slug.hs create mode 100644 Handler/Email.hs create mode 100644 Handler/Profile.hs create mode 100644 Handler/ResetToken.hs create mode 100644 templates/profile.hamlet create mode 100644 templates/profile.lucius create mode 100644 test/Data/SlugSpec.hs diff --git a/Application.hs b/Application.hs index 0828248..73fdd9a 100644 --- a/Application.hs +++ b/Application.hs @@ -7,7 +7,6 @@ module Application import Import import Settings -import Yesod.Auth import Yesod.Default.Config import Yesod.Default.Main import Yesod.Default.Handlers @@ -21,10 +20,16 @@ import Control.Concurrent (forkIO, threadDelay) import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize) import Network.Wai.Logger (clockDateCacher) import Yesod.Core.Types (loggerSet, Logger (Logger)) +import qualified System.Random.MWC as MWC +import qualified Network.Wai as Wai +import Network.Wai.Middleware.MethodOverride (methodOverride) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Handler.Home +import Handler.Profile +import Handler.Email +import Handler.ResetToken -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -51,7 +56,11 @@ makeApplication conf = do -- Create the WAI application and apply middlewares app <- toWaiAppPlain foundation let logFunc = messageLoggerSource foundation (appLogger foundation) - return (logWare app, logFunc) + middleware = logWare . defaultWAIMiddleware + return (middleware app, logFunc) + +defaultWAIMiddleware :: Wai.Middleware -- FIXME move upstream +defaultWAIMiddleware = methodOverride -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization. @@ -77,8 +86,18 @@ makeFoundation conf = do updateLoop _ <- forkIO updateLoop + gen <- MWC.createSystemRandom + let logger = Yesod.Core.Types.Logger loggerSet' getter - foundation = App conf s p manager dbconf logger + foundation = App + { settings = conf + , getStatic = s + , connPool = p + , httpManager = manager + , persistConfig = dbconf + , appLogger = logger + , genIO = gen + } -- Perform database migration using our application's logging settings. runLoggingT diff --git a/Data/Slug.hs b/Data/Slug.hs new file mode 100644 index 0000000..3c034c5 --- /dev/null +++ b/Data/Slug.hs @@ -0,0 +1,88 @@ +module Data.Slug + ( Slug + , mkSlug + , safeMakeSlug + , unSlug + , InvalidSlugException (..) + , HasGenIO (..) + , randomSlug + , slugField + ) where + +import ClassyPrelude.Yesod +import Database.Persist.Sql (PersistFieldSql) +import qualified System.Random.MWC as MWC +import Control.Monad.Reader (MonadReader, ask) +import GHC.Prim (RealWorld) +import Text.Blaze (ToMarkup) + +newtype Slug = Slug { unSlug :: Text } + deriving (Show, Read, Eq, Typeable, PersistField, PersistFieldSql, ToMarkup) + +mkSlug :: MonadThrow m => Text -> m Slug +mkSlug t + | length t < minLen = throwM $ InvalidSlugException t "Too short" + | length t > maxLen = throwM $ InvalidSlugException t "Too long" + | any (not . validChar) t = throwM $ InvalidSlugException t "Contains invalid characters" + | "-" `isPrefixOf` t = throwM $ InvalidSlugException t "Must not start with a hyphen" + | otherwise = return $ Slug t + where + +minLen, maxLen :: Int +minLen = 3 +maxLen = 30 + +validChar :: Char -> Bool +validChar c = + ('A' <= c && c <= 'Z') || + ('a' <= c && c <= 'z') || + ('0' <= c && c <= '9') || + c == '-' || + c == '_' + +data InvalidSlugException = InvalidSlugException !Text !Text + deriving (Show, Typeable) +instance Exception InvalidSlugException + +instance PathPiece Slug where + toPathPiece = unSlug + fromPathPiece = mkSlug + +class HasGenIO a where + getGenIO :: a -> MWC.GenIO +instance s ~ RealWorld => HasGenIO (MWC.Gen s) where + getGenIO = id + +safeMakeSlug :: (MonadIO m, MonadReader env m, HasGenIO env) + => Text + -> Bool -- ^ force some randomness? + -> m Slug +safeMakeSlug orig forceRandom + | needsRandom || forceRandom = do + gen <- liftM getGenIO ask + cs <- liftIO $ replicateM 3 $ MWC.uniformR (0, 61) gen + return $ Slug $ cleaned ++ pack ('_':map toChar cs) + | otherwise = return $ Slug cleaned + where + cleaned = take (maxLen - minLen - 1) $ dropWhile (== '-') $ filter validChar orig + needsRandom = length cleaned < minLen + +toChar :: Int -> Char +toChar i + | i < 26 = toEnum $ fromEnum 'A' + i + | i < 52 = toEnum $ fromEnum 'a' + i - 26 + | otherwise = toEnum $ fromEnum '0' + i - 52 + +randomSlug :: (MonadIO m, MonadReader env m, HasGenIO env) + => Int -- ^ length + -> m Slug +randomSlug (min maxLen . max minLen -> len) = do + gen <- liftM getGenIO ask + cs <- liftIO $ replicateM len $ MWC.uniformR (0, 61) gen + return $ Slug $ pack $ map toChar cs + +slugField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Slug +slugField = + checkMMap go unSlug textField + where + go = return . either (Left . tshow) Right . mkSlug diff --git a/Foundation.hs b/Foundation.hs index a453f98..37f0249 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -1,24 +1,22 @@ module Foundation where -import Prelude -import Yesod -import Yesod.Static +import ClassyPrelude.Yesod import Yesod.Auth import Yesod.Auth.BrowserId import Yesod.Auth.GoogleEmail import Yesod.Default.Config import Yesod.Default.Util (addStaticContentExternal) -import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager)) import qualified Settings import Settings.Development (development) import qualified Database.Persist -import Database.Persist.Sql (SqlPersistT) import Settings.StaticFiles import Settings (widgetFile, Extra (..)) import Model import Text.Jasmine (minifym) import Text.Hamlet (hamletFile) import Yesod.Core.Types (Logger) +import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug) +import qualified System.Random.MWC as MWC -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -31,8 +29,12 @@ data App = App , httpManager :: Manager , persistConfig :: Settings.PersistConf , appLogger :: Logger + , genIO :: !MWC.GenIO } +instance HasGenIO App where + getGenIO = genIO + instance HasHttpManager App where getHttpManager = httpManager @@ -61,6 +63,7 @@ instance Yesod App where defaultLayout widget = do master <- getYesod mmsg <- getMessage + muser <- maybeAuth -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -74,6 +77,10 @@ instance Yesod App where , css_bootstrap_css ]) $(widgetFile "default-layout") + + mcurr <- getCurrentRoute + let notHome = mcurr /= Just HomeR + giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") -- This is done to provide an optimization for serving static files from @@ -122,21 +129,73 @@ instance YesodAuth App where -- Where to send a user after logout logoutDest _ = HomeR - getAuthId creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (Entity uid _) -> return $ Just uid + getAuthId creds = do + muid <- maybeAuthId + join $ runDB $ case muid of Nothing -> do - fmap Just $ insert User - { userIdent = credsIdent creds - , userPassword = Nothing - } + x <- getBy $ UniqueEmail $ credsIdent creds + case x of + Just (Entity _ email) -> return $ return $ Just $ emailUser email + Nothing -> do + handle' <- getHandle (0 :: Int) + token <- getToken + userid <- insert User + { userHandle = handle' + , userDisplay = credsIdent creds + , userToken = token + } + void $ insert Email + { emailEmail = credsIdent creds + , emailUser = userid + } + return $ return $ Just userid + Just uid -> do + memail <- getBy $ UniqueEmail $ credsIdent creds + case memail of + Nothing -> do + void $ insert Email + { emailEmail = credsIdent creds + , emailUser = uid + } + return $ do + setMessage $ toHtml $ concat + [ "Email address " + , credsIdent creds + , " added to your account." + ] + redirect ProfileR + Just _ -> invalidArgs $ return $ concat + [ "The email address " + , credsIdent creds + , " is already associated with a different account." + ] + where + handleBase = takeWhile (/= '@') (credsIdent creds) + getHandle cnt | cnt > 50 = error "Could not get a unique slug" + getHandle cnt = do + slug <- lift $ safeMakeSlug handleBase (cnt > 0) + muser <- getBy $ UniqueHandle slug + case muser of + Nothing -> return slug + Just _ -> getHandle (cnt + 1) -- You can add other plugins like BrowserID, email or OAuth here authPlugins _ = [authBrowserId def, authGoogleEmail] authHttpManager = httpManager +getToken :: YesodDB App Slug +getToken = + go (0 :: Int) + where + go cnt | cnt > 50 = error "Could not get a unique token" + go cnt = do + slug <- lift $ randomSlug 25 + muser <- getBy $ UniqueToken slug + case muser of + Nothing -> return slug + Just _ -> go (cnt + 1) + -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage App FormMessage where diff --git a/Handler/Email.hs b/Handler/Email.hs new file mode 100644 index 0000000..f2dc73c --- /dev/null +++ b/Handler/Email.hs @@ -0,0 +1,14 @@ +module Handler.Email where + +import Import +import Database.Persist.Sql (deleteWhereCount) + +deleteEmailR :: EmailId -> Handler () +deleteEmailR eid = do + Entity uid _ <- requireAuth + cnt <- runDB $ deleteWhereCount [EmailUser ==. uid, EmailId ==. eid] + setMessage $ + if cnt > 0 + then "Email address deleted" + else "No matching email address found" + redirect ProfileR diff --git a/Handler/Home.hs b/Handler/Home.hs index 917bdf1..9e6a998 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -12,28 +12,6 @@ import Import -- inclined, or create a single monolithic file. getHomeR :: Handler Html getHomeR = do - (formWidget, formEnctype) <- generateFormPost sampleForm - let submission = Nothing :: Maybe (FileInfo, Text) - handlerName = "getHomeR" :: Text defaultLayout $ do - aDomId <- newIdent - setTitle "Welcome To Yesod!" + setTitle "Stackage Server" $(widgetFile "homepage") - -postHomeR :: Handler Html -postHomeR = do - ((result, formWidget), formEnctype) <- runFormPost sampleForm - let handlerName = "postHomeR" :: Text - submission = case result of - FormSuccess res -> Just res - _ -> Nothing - - defaultLayout $ do - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -sampleForm :: Form (FileInfo, Text) -sampleForm = renderDivs $ (,) - <$> fileAFormReq "Choose a file" - <*> areq textField "What's on the file?" Nothing diff --git a/Handler/Profile.hs b/Handler/Profile.hs new file mode 100644 index 0000000..6d37243 --- /dev/null +++ b/Handler/Profile.hs @@ -0,0 +1,30 @@ +module Handler.Profile where + +import Import +import Data.Slug (slugField) + +userForm :: User -> Form User +userForm user = renderBootstrap $ User + <$> areq slugField "User handle" + { fsTooltip = Just "Used for URLs" + } (Just $ userHandle user) + <*> areq textField "Display name" (Just $ userDisplay user) + <*> pure (userToken user) + +getProfileR :: Handler Html +getProfileR = do + Entity uid user <- requireAuth + ((result, userWidget), enctype) <- runFormPost $ userForm user + case result of + FormSuccess user' -> do + runDB $ replace uid user' + setMessage "Profile updated" + redirect ProfileR + _ -> return () + emails <- runDB $ selectList [EmailUser ==. uid] [Asc EmailEmail] + defaultLayout $ do + setTitle "Your Profile" + $(widgetFile "profile") + +putProfileR :: Handler Html +putProfileR = getProfileR diff --git a/Handler/ResetToken.hs b/Handler/ResetToken.hs new file mode 100644 index 0000000..babaf99 --- /dev/null +++ b/Handler/ResetToken.hs @@ -0,0 +1,12 @@ +module Handler.ResetToken where + +import Import + +postResetTokenR :: Handler () +postResetTokenR = do + Entity uid _ <- requireAuth + runDB $ do + token <- getToken + update uid [UserToken =. token] + setMessage "Token updated" + redirect ProfileR diff --git a/Import.hs b/Import.hs index 2979a1d..f55b4ad 100644 --- a/Import.hs +++ b/Import.hs @@ -8,3 +8,4 @@ import Model as Import import Settings as Import import Settings.Development as Import import Settings.StaticFiles as Import +import Yesod.Auth as Import diff --git a/Model.hs b/Model.hs index 19e0640..36ed1cb 100644 --- a/Model.hs +++ b/Model.hs @@ -5,6 +5,7 @@ import Yesod import Data.Text (Text) import Database.Persist.Quasi import Data.Typeable (Typeable) +import Data.Slug (Slug) -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities diff --git a/config/models b/config/models index cd7d6ca..f4ef0c5 100644 --- a/config/models +++ b/config/models @@ -1,12 +1,15 @@ User - ident Text - password Text Maybe - UniqueUser ident + handle Slug + display Text + token Slug + UniqueHandle handle + UniqueToken token deriving Typeable Email email Text - user UserId Maybe - verkey Text Maybe + user UserId UniqueEmail email - -- By default this file is used in Model.hs (which is imported by Foundation.hs) +Verkey + email Text + verkey Text diff --git a/config/routes b/config/routes index c1f7063..b8be2cd 100644 --- a/config/routes +++ b/config/routes @@ -4,4 +4,7 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET -/ HomeR GET POST +/ HomeR GET +/profile ProfileR GET PUT +/email/#EmailId EmailR DELETE +/reset-token ResetTokenR POST diff --git a/stackage-server.cabal b/stackage-server.cabal index 6ae48de..9f6274d 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -19,7 +19,11 @@ library Settings Settings.StaticFiles Settings.Development + Data.Slug Handler.Home + Handler.Profile + Handler.Email + Handler.ResetToken if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -40,6 +44,9 @@ library EmptyDataDecls NoMonomorphismRestriction DeriveDataTypeable + ViewPatterns + TypeSynonymInstances + FlexibleInstances build-depends: base >= 4 && < 5 , yesod >= 1.2.5 && < 1.3 @@ -66,8 +73,14 @@ library , conduit >= 1.0 && < 2.0 , monad-logger >= 0.3 && < 0.4 , fast-logger >= 2.1.4 && < 2.2 + , wai >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2 , classy-prelude-yesod >= 0.9 && < 0.9.1 + , mwc-random >= 0.13 && < 0.14 + , mtl >= 2.1 && < 2.2 + , blaze-markup >= 0.6 && < 0.7 + , ghc-prim + , ghc-prim executable stackage-server if flag(library-only) @@ -98,3 +111,6 @@ test-suite test , monad-logger , transformers , hspec + , classy-prelude-yesod + , mtl + , mwc-random diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index a5e6ab3..c07264a 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -8,7 +8,10 @@ $newline never - #{pageTitle pc} + <title> + #{pageTitle pc} + $if notHome + :: Stackage Server <meta name="description" content=""> <meta name="author" content=""> diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index fa86744..8b47727 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -1,3 +1,14 @@ +<nav .navbar .navbar-default role=navigation> + <p> + <a href=@{HomeR}>Home + $maybe Entity _ user <- muser + You are logged in as #{userDisplay user} (#{userHandle user}). + View public page + <a href=@{ProfileR}>Edit profile + <a href=@{AuthR LogoutR}>Logout + $nothing + <a href=@{AuthR LoginR}>Login + $maybe msg <- mmsg - <div #message>#{msg} + <div .alert .alter-info>#{msg} ^{widget} diff --git a/templates/profile.hamlet b/templates/profile.hamlet new file mode 100644 index 0000000..6113317 --- /dev/null +++ b/templates/profile.hamlet @@ -0,0 +1,28 @@ +<h2>Email addresses +$if length emails <= 1 + $forall Entity _ email <- emails + <p>#{emailEmail email} +$else + <ul> + $forall Entity eid email <- emails + <li .email> + #{emailEmail email} + <form method=post action=@{EmailR eid}?_method=DELETE> + <button .btn>Remove + +<p> + <a href=@{AuthR LoginR}>Add another email address. + +<h2>Profile + +<form method=post action=@{ProfileR}?_method=PUT enctype=#{enctype} role=form> + <div .form-group> + ^{userWidget} + <button .btn>Update + +<h2>Security token + +<p> + Your security token is #{userToken user}. + <form method=post action=@{ResetTokenR}> + <button>Reset token diff --git a/templates/profile.lucius b/templates/profile.lucius new file mode 100644 index 0000000..1550d97 --- /dev/null +++ b/templates/profile.lucius @@ -0,0 +1,3 @@ +.email > form { + display: inline-block; +} diff --git a/test/Data/SlugSpec.hs b/test/Data/SlugSpec.hs new file mode 100644 index 0000000..9453dd1 --- /dev/null +++ b/test/Data/SlugSpec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Data.SlugSpec where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Data.Slug +import ClassyPrelude.Yesod +import qualified System.Random.MWC as MWC +import Control.Monad.Reader (runReaderT) + +spec :: Spec +spec = describe "Data.Slug" $ do + prop "safeMakeSlug generates valid slugs" $ \(pack -> orig) -> do + gen <- MWC.createSystemRandom + slug <- runReaderT (safeMakeSlug orig False) gen + mkSlug (unSlug slug) `shouldBe` Just slug + prop "randomization works" $ \(pack -> orig) -> do + gen <- MWC.createSystemRandom + slug1 <- runReaderT (safeMakeSlug orig True) gen + slug2 <- runReaderT (safeMakeSlug orig True) gen + when (slug1 == slug2) $ error $ show (slug1, slug2) diff --git a/test/main.hs b/test/main.hs index 8901ef3..35e2c68 100644 --- a/test/main.hs +++ b/test/main.hs @@ -10,6 +10,8 @@ import Yesod.Test import Test.Hspec (hspec) import Application (makeFoundation) +import qualified Data.SlugSpec + main :: IO () main = do conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing) @@ -17,5 +19,6 @@ main = do } foundation <- makeFoundation conf hspec $ do + Data.SlugSpec.spec yesodSpec foundation $ do return ()