Authentication system

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

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

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

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

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

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

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

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

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

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

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

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

templates/default-layout-wrapper.hamlet

@@ -8,7 +8,10 @@ $newline never
     <head>
         <meta charset="UTF-8">
 
-        <title>#{pageTitle pc}
+        <title>
+            #{pageTitle pc}
+            $if notHome
+                :: Stackage Server
         <meta name="description" content="">
         <meta name="author" content="">
 

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}

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

templates/profile.lucius

@@ -0,0 +1,3 @@
+.email > form {
+    display: inline-block;
+}

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)

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 ()