login and signup via plugin work now

2017-04-24 07:46:34 +02:00 · 2017-04-24 07:46:34 +02:00 · be32449430
commit be32449430
parent a379d8af45
18 changed files with 331 additions and 258 deletions
--- a/Application.hs
+++ b/Application.hs
@ -48,9 +48,10 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
 import Handler.Home
-import Handler.Signup
-import Handler.Login
-import Handler.Activate
+-- import Handler.Signup
+-- import Handler.Login
+-- import Handler.Activate
+-- import Handler.Reactivate
 import Handler.Profile
 import Handler.Upload
 import Handler.NewAlbum
@ -58,7 +59,6 @@ import Handler.Album
 import Handler.Medium
 import Handler.AlbumSettings
 import Handler.MediumSettings
-import Handler.Reactivate
 import Handler.ProfileSettings
 import Handler.ProfileDelete
 import Handler.Admin
--- a/Foundation.hs
+++ b/Foundation.hs
@ -14,6 +14,8 @@
 --  You should have received a copy of the GNU Affero General Public License
 --  along with this program.  If not, see <http://www.gnu.org/licenses/>.

+{-# LANGUAGE FlexibleInstances #-}
+
 module Foundation where

 import Prelude
@ -31,8 +33,12 @@ import Yesod.Core.Types
 -- costom imports
 import qualified Data.Text as T
 import Data.Text.Encoding
+import Data.Maybe (fromJust)
 import Network.Wai
-import Helper
+import Helper hiding (hmacKeccak)
+import Yesod.Auth
+import Yesod.Auth.HmacKeccak
+import System.IO.Unsafe (unsafePerformIO)

 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@ -68,28 +74,20 @@ renderLayout widget = do
    master <- getYesod
    route <- getCurrentRoute
    mmsg <- getMessage
-    msu <- lookupSession "userId"
-    username <- case msu of
-      Just a -> do
-        let uId = getUserIdFromText a
-        user <- runDB $ getJust uId
-        return $ userName user
+    -- msu <- lookupSession "userId"
+    musername <- maybeAuthId
+    slug <- case musername of
+      Just name -> do
+        user <- runDB $ getBy $ UniqueUser name
+        return $ userSlug $ entityVal $ fromJust user
      Nothing ->
        return ("" :: T.Text)
-    slug <- case msu of
-      Just a -> do
-        let uId = getUserIdFromText a
-        user <- runDB $ getJust uId
-        return $ userSlug user
+    admin <- case musername of
+      Just name -> do
+        user <- runDB $ getBy $ UniqueUser name
+        return $ userAdmin $ entityVal $ fromJust user
      Nothing ->
-        return ("" :: T.Text)
-    madmin <- case msu of
-      Just a -> do
-        let uId = getUserIdFromText a
-        user <- runDB $ getJust uId
-        return $ Just $ userAdmin user
-      Nothing ->
-        return Nothing
+        return False
    let block = appSignupBlocked $ appSettings master

    -- We break up the default layout into two components:
@ -114,6 +112,7 @@ renderLayout widget = do
    pc <- widgetToPageContent $ do
        mapM_ addScript $ map StaticR
            [ js_picturefill_js
+            , js_jquery_min_js
            ]
        mapM_ addStylesheet $ map StaticR
            [ css_bootstrap_min_css
@ -206,28 +205,22 @@ instance YesodPersist App where
 instance YesodPersistRunner App where
    getDBRunner = defaultGetDBRunner appConnPool

-- instance YesodAuth App where
--    type AuthId App = UserId
+instance YesodAuth App where
+    type AuthId App = Username

-    -- Where to send a user after successful login
--    loginDest _ = HomeR
-    -- Where to send a user after logout
--    logoutDest _ = HomeR
+  -- Where to send a user after successful login
+    loginDest _ = HomeR
+  -- 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
--            Nothing -> do
--                fmap Just $ insert User
--                    { userIdent = credsIdent creds
--                    , userPassword = Nothing
--                    }
+    getAuthId = return . Just . credsIdent

-    -- You can add other plugins like BrowserID, email or OAuth here
--    authPlugins _ = [authBrowserId def]
+  -- You can add other plugins like BrowserID, email or OAuth here
+    authPlugins _ = [hmacPlugin]

--    authHttpManager = httpManager
+    authHttpManager = error "no HttpManager needed"
+
+    maybeAuthId = lookupSession credsKey

 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
@ -244,3 +237,60 @@ instance RenderMessage App FormMessage where
 -- wiki:
 --
 -- https://github.com/yesodweb/yesod/wiki/Sending-email
+
+instance YesodHmacKeccak (HmacPersistDB App User Token) App where
+  runHmacDB = runHmacPersistDB
+
+instance UserCredentials (Entity User) where
+  userUserName = userName . entityVal
+  userUserSalt = userSalt . entityVal
+  userUserSalted = userSalted . entityVal
+  userUserEmail = userEmail . entityVal
+  userUserActive = userActive . entityVal
+
+instance TokenData (Entity Token) where
+  tokenTokenKind = tokenKind . entityVal
+  tokenTokenUsername = tokenUsername . entityVal
+  tokenTokenToken = tokenToken . entityVal
+
+instance PersistUserCredentials User where
+  userUsernameF   = UserName
+  userUserSaltF   = UserSalt
+  userUserSaltedF = UserSalted
+  userUserEmailF  = UserEmail
+  userUserActiveF = UserActive
+  uniqueUsername  = UniqueUser
+
+  userCreate name email salt = User name name email salt "" [] False (-1) False
+
+instance PersistToken Token where
+  tokenTokenTokenF = TokenToken
+  tokenTokenKindF = TokenKind
+  tokenTokenUsernameF = TokenUsername
+  uniqueToken = UniqueToken
+
+  tokenCreate t u k = Token t k u
+
+instance HmacSendMail App where
+  sendVerifyEmail username email url =
+    sendMail email "Please activate your account!" $
+      [shamlet|
+<h1>Hello #{username} and welcome to Eidolon!
+To complete your signup process, please activate your account by visiting the
+following link:
+<a href=#{url}>#{url}
+
+See you soon!
+      |]
+
+  sendReactivateEmail username email url = do
+    muser <- runDB $ getBy $ UniqueUser username
+    let user = entityVal $ fromJust muser
+    sendMail email "Reset your password" $
+      [shamlet|
+<h1>Welcome again to Eidolon #{userSlug user}
+To reset your password visit the following link:
+<a href=#{url}>#{url}
+
+See you soon!
+      |]
--- a/Handler/Activate.hs
+++ b/Handler/Activate.hs
@ -15,171 +15,186 @@
 --  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 module Handler.Activate where

-import Import as I hiding (returnJson)
-import Data.Text
-import Data.Text.Encoding
-import Data.Maybe
-import System.Directory
-import System.FilePath
-
-import qualified Data.ByteString.Char8 as BC
-
-import Handler.Login
-
-getActivateR :: Text -> Handler Html
-getActivateR token = do
-  t <- runDB $ selectFirst [ActivatorToken ==. token] []
-  (activateRawWidget, _) <- generateFormPost $
-    renderBootstrap3 BootstrapBasicForm activateForm
-  case t of
-    Nothing -> do
-      mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
-      case mToken of
-        Just (Entity _ uToken) -> do
-          user <- runDB $ getJust (fromJust $ tokenUser uToken)
-          let hexSalt = toHex $ userSalt user
-          master <- getYesod
-          let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
-          defaultLayout $ do
-            setTitle "Activate your account"
-            $(widgetFile "activate")
-        _ -> do
-          setMessage "Invalid token!"
-          redirect HomeR
-    Just (Entity _ activator) -> do
-      let uSalt = userSalt $ activatorUser activator
-      mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
-      case mToken of
-        Just (Entity _ _) -> do
-          let hexSalt = toHex uSalt
-          master <- getYesod
-          let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
-          defaultLayout $
-            $(widgetFile "activate")
-        _ -> do
-          setMessage "Invalid token!"
-          redirect HomeR
-
-postActivateR :: Text -> Handler RepJson
-postActivateR token = do
-  msalted <- fromJust <$> lookupPostParam "salted"
-  let salted = fromHex' $ unpack msalted
-  mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
-  case mToken of
-    Just (Entity uTokenId uToken) ->
-      if
-        isNothing (tokenUser uToken)
-        then do
-          newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
-          case newUser of
-            Just (Entity aId activ) -> do
-              namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
-              if
-                I.null namesakes
-                then do
-                  -- putting user in active state
-                  uId <- runDB $ insert $ activatorUser activ
-                  runDB $ update uId [UserSalted =. salted]
-                  -- create user directory
-                  liftIO $ createDirectoryIfMissing True $
-                    "static" </> "data" </> unpack (extractKey uId)
-                  -- cleanup
-                  runDB $ delete aId
-                  runDB $ delete uTokenId
-                  -- login and redirect
-                  setSession "userId" (extractKey uId)
-                  welcomeLink <- ($ ProfileR uId) <$> getUrlRender
-                  returnJson ["welcome" .= welcomeLink]
-                else do
-                  -- cleanup
-                  runDB $ delete aId
-                  runDB $ delete uTokenId
-                  returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String)
-            Nothing ->
-              returnJsonError ("Invalid token" :: String)
-        else do
-          runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-          -- cleanup
-          runDB $ delete uTokenId
-          setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
-          welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
-          returnJson ["welcome" .= welcomeLink]
-    _ ->
-      returnJsonError ("Invalid activation token!" :: String)
-
-data ActivateFormRes = ActivateFormRes
-  { pass1 :: Text
-  , pass2 :: Text
-  }
-
-activateForm :: AForm Handler ActivateFormRes
-activateForm = ActivateFormRes
-  <$> areq passwordField (bfs ("Password" :: Text)) Nothing
-  <*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing
-  <*  bootstrapSubmit ("Activate" :: BootstrapSubmit Text)
-
-postActivateRawR :: Text -> Handler Html
-postActivateRawR token = do
-  ((res, _), _) <- runFormPost $
-    renderBootstrap3 BootstrapBasicForm activateForm
-  case res of
-    FormSuccess pwd -> do
-      if pass1 pwd == pass2 pwd
-      then do
-        mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
-        case mToken of
-          Just (Entity uTokenId uToken) ->
-            if
-              isNothing (tokenUser uToken)
-              then do
-                newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
-                case newUser of
-                  Just (Entity aId activ) -> do
-                    namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
-                    if
-                      I.null namesakes
-                      then do
-                        let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd)
-                        -- putting user in active state
-                        uId <- runDB $ insert $ activatorUser activ
-                        runDB $ update uId [UserSalted =. salted]
-                        -- create user directory
-                        liftIO $ createDirectoryIfMissing True $
-                          "static" </> "data" </> unpack (extractKey uId)
-                        -- cleanup
-                        runDB $ delete aId
-                        runDB $ delete uTokenId
-                        -- login and redirect
-                        setSession "userId" (extractKey uId)
-                        setMessage "Successfully activated"
-                        redirect $ ProfileR uId
-                      else do
-                        -- cleanup
-                        runDB $ delete aId
-                        runDB $ delete uTokenId
-                        setMessage "Somebody already activated your username. Your token has been deleted"
-                        redirect HomeR
-                  Nothing -> do
-                    setMessage "Invalid token"
-                    redirect HomeR
-              else do
-                uuser <- runDB $ getJust $ fromJust $ tokenUser uToken
-                let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd)
-                runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-                -- cleanup
-                runDB $ delete uTokenId
-                setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
-                setMessage "Successfully activated"
-                redirect $ ProfileR (fromJust $ tokenUser uToken)
-          Nothing -> do
-            setMessage "Invalid activation token!"
-            redirect HomeR
-      else do
-        setMessage "Passwords must match!"
-        redirect $ ActivateR token
-    _ -> do
-      setMessage "Activation error"
-      redirect HomeR
+-- import Import as I hiding (returnJson)
+-- import Data.Text
+-- import Data.Text.Encoding
+-- import Data.Maybe
+-- import System.Directory
+-- import System.FilePath
+-- 
+-- import qualified Data.ByteString.Char8 as BC
+-- 
+-- import Handler.Login
+-- 
+-- -- getActivateR :: Text -> Handler Html
+-- getActivateR token = do
+--   t <- runDB $ getBy $ UniqueToken token
+--   case t of
+--     Nothing -> do
+--       setMessage "Invalid token!"
+--       redirect HomeR
+--     Just (Entity tId token) -> do
+--       master <- getYesod
+--       (Entity uId user) <-
+--         runDB $ getJust <$> getBy $ UniqueUser $ tokenUsername token
+--       let hexSalt = toHex $ userSalt user
+--           addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
+--       defaultLayout $ do
+--         setTitle "Activate your account"
+--         $(widgetFile "activate")
+-- 
+--   t <- runDB $ selectFirst [ActivatorToken ==. token] []
+--   (activateRawWidget, _) <- generateFormPost $
+--     renderBootstrap3 BootstrapBasicForm activateForm
+--   case t of
+--     Nothing -> do
+--       mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
+--       case mToken of
+--         Just (Entity _ uToken) -> do
+--           user <- runDB $ getBy $ UniqueUser $ tokenUsername uToken
+--           let hexSalt = toHex $ userSalt user
+--           master <- getYesod
+--           let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
+--           defaultLayout $ do
+--             setTitle "Activate your account"
+--             $(widgetFile "activate")
+--         _ -> do
+--           setMessage "Invalid token!"
+--           redirect HomeR
+--     Just (Entity _ activator) -> do
+--       let uSalt = userSalt $ activatorUser activator
+--       mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
+--       case mToken of
+--         Just (Entity _ _) -> do
+--           let hexSalt = toHex uSalt
+--           master <- getYesod
+--           let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
+--           defaultLayout $
+--             $(widgetFile "activate")
+--         _ -> do
+--           setMessage "Invalid token!"
+--           redirect HomeR
+-- 
+-- postActivateR :: Text -> Handler RepJson
+-- postActivateR token = do
+--   msalted <- fromJust <$> lookupPostParam "salted"
+--   let salted = fromHex' $ unpack msalted
+--   mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
+--   case mToken of
+--     Just (Entity uTokenId uToken) ->
+--       if
+--         isNothing (tokenUser uToken)
+--         then do
+--           newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
+--           case newUser of
+--             Just (Entity aId activ) -> do
+--               namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
+--               if
+--                 I.null namesakes
+--                 then do
+--                   -- putting user in active state
+--                   uId <- runDB $ insert $ activatorUser activ
+--                   runDB $ update uId [UserSalted =. salted]
+--                   -- create user directory
+--                   liftIO $ createDirectoryIfMissing True $
+--                     "static" </> "data" </> unpack (extractKey uId)
+--                   -- cleanup
+--                   runDB $ delete aId
+--                   runDB $ delete uTokenId
+--                   -- login and redirect
+--                   setSession "userId" (extractKey uId)
+--                   welcomeLink <- ($ ProfileR uId) <$> getUrlRender
+--                   returnJson ["welcome" .= welcomeLink]
+--                 else do
+--                   -- cleanup
+--                   runDB $ delete aId
+--                   runDB $ delete uTokenId
+--                   returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String)
+--             Nothing ->
+--               returnJsonError ("Invalid token" :: String)
+--         else do
+--           runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
+--           -- cleanup
+--           runDB $ delete uTokenId
+--           setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
+--           welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
+--           returnJson ["welcome" .= welcomeLink]
+--     _ ->
+--       returnJsonError ("Invalid activation token!" :: String)
+-- 
+-- data ActivateFormRes = ActivateFormRes
+--   { pass1 :: Text
+--   , pass2 :: Text
+--   }
+-- 
+-- activateForm :: AForm Handler ActivateFormRes
+-- activateForm = ActivateFormRes
+--   <$> areq passwordField (bfs ("Password" :: Text)) Nothing
+--   <*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing
+--   <*  bootstrapSubmit ("Activate" :: BootstrapSubmit Text)
+-- 
+-- postActivateRawR :: Text -> Handler Html
+-- postActivateRawR token = do
+--   ((res, _), _) <- runFormPost $
+--     renderBootstrap3 BootstrapBasicForm activateForm
+--   case res of
+--     FormSuccess pwd -> do
+--       if pass1 pwd == pass2 pwd
+--       then do
+--         mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
+--         case mToken of
+--           Just (Entity uTokenId uToken) ->
+--             if
+--               isNothing (tokenUser uToken)
+--               then do
+--                 newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
+--                 case newUser of
+--                   Just (Entity aId activ) -> do
+--                     namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
+--                     if
+--                       I.null namesakes
+--                       then do
+--                         let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd)
+--                         -- putting user in active state
+--                         uId <- runDB $ insert $ activatorUser activ
+--                         runDB $ update uId [UserSalted =. salted]
+--                         -- create user directory
+--                         liftIO $ createDirectoryIfMissing True $
+--                           "static" </> "data" </> unpack (extractKey uId)
+--                         -- cleanup
+--                         runDB $ delete aId
+--                         runDB $ delete uTokenId
+--                         -- login and redirect
+--                         setSession "userId" (extractKey uId)
+--                         setMessage "Successfully activated"
+--                         redirect $ ProfileR uId
+--                       else do
+--                         -- cleanup
+--                         runDB $ delete aId
+--                         runDB $ delete uTokenId
+--                         setMessage "Somebody already activated your username. Your token has been deleted"
+--                         redirect HomeR
+--                   Nothing -> do
+--                     setMessage "Invalid token"
+--                     redirect HomeR
+--               else do
+--                 uuser <- runDB $ getJust $ fromJust $ tokenUser uToken
+--                 let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd)
+--                 runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
+--                 -- cleanup
+--                 runDB $ delete uTokenId
+--                 setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
+--                 setMessage "Successfully activated"
+--                 redirect $ ProfileR (fromJust $ tokenUser uToken)
+--           Nothing -> do
+--             setMessage "Invalid activation token!"
+--             redirect HomeR
+--       else do
+--         setMessage "Passwords must match!"
+--         redirect $ ActivateR token
+--     _ -> do
+--       setMessage "Activation error"
+--       redirect HomeR

 -- returnJson :: (Monad m, a ~ Value) =>
 --               [(Text, a)] -> m RepJson
--- a/Handler/AdminProfileSettings.hs
+++ b/Handler/AdminProfileSettings.hs
@ -139,6 +139,7 @@ adminProfileForm owner = User
  <*> pure (userAlbums owner)
  <*> areq boolField (bfs ("Admin" :: T.Text)) (Just $ userAdmin owner)
  <*> areq (selectField licenses) (bfs ("Default licence" :: T.Text)) (Just $ userDefaultLicence owner)
+  <*> pure (userActive owner)
  <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
  where
    licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
--- a/Handler/AlbumSettings.hs
+++ b/Handler/AlbumSettings.hs
@ -49,7 +49,7 @@ getAlbumSettingsR albumId = do
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to change settings"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR
@ -121,7 +121,7 @@ postAlbumSettingsR albumId = do
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to change settings"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR
@ -160,7 +160,7 @@ getAlbumDeleteR albumId = do
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to delete albums"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR
@ -220,7 +220,7 @@ postAlbumDeleteR albumId = do
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to delete albums"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR
--- a/Handler/Commons.hs
+++ b/Handler/Commons.hs
@ -51,7 +51,7 @@ loginIsAdmin = do
        else
          return $ Left ("You have no admin rights", HomeR)
    Nothing ->
-      return $ Left ("You are not logged in", LoginR)
+      return $ Left ("You are not logged in", AuthR LoginR)

 profileCheck :: IsString t => UserId -> Handler (Either (t, Route App) User)
 profileCheck userId = do
@ -69,7 +69,7 @@ profileCheck userId = do
            else
              return $ Left ("You can only change your own profile settings", UserR $ userName user)
        Nothing ->
-          return $ Left ("You nedd to be logged in to change settings", LoginR)
+          return $ Left ("You nedd to be logged in to change settings", AuthR LoginR)
    Nothing ->
      return $ Left ("This user does not exist", HomeR)

@ -93,7 +93,7 @@ mediumCheck mediumId = do
            else
              return $ Left ("You must own this medium to change its settings", MediumR mediumId)
        Nothing ->
-          return $ Left ("You must be logged in to change settings", LoginR)
+          return $ Left ("You must be logged in to change settings", AuthR LoginR)
    Nothing ->
      return $ Left ("This medium does not exist", HomeR)

--- a/Handler/Login.hs
+++ b/Handler/Login.hs
@ -52,12 +52,12 @@ postLoginR = do
  mHexResponse <- lookupPostParam "response"
  case (mUserName, mHexToken, mHexResponse) of
    (Just userName, Nothing, Nothing) -> do
-      tempUser <- runDB $ selectFirst [UserName ==. userName] []
+      tempUser <- runDB $ getBy $ UniqueUser userName
      case tempUser of
        Just (Entity userId user) -> do
          let salt = userSalt user
          token <- liftIO makeRandomToken
-          runDB $ insert_ $ Token (encodeUtf8 token) "login" (Just userId)
+          runDB $ insert_ $ Token (encodeUtf8 token) "login" userName
          returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)]
        Nothing ->
          returnJsonError ("No such user" :: T.Text)
@ -67,16 +67,17 @@ postLoginR = do
        savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] []
        case savedToken of
          Just (Entity tokenId token) -> do
-            let savedUserId = tokenUser token
-            queriedUser <- runDB $ getJust (fromJust savedUserId)
-            let salted = userSalted queriedUser
-            let hexSalted = toHex salted
-            let expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
+            let savedUserName = tokenUsername token
+            mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName
+            let queriedUser = entityVal $ fromJust mqueriedUser
+                salted = userSalted queriedUser
+                hexSalted = toHex salted
+                expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
            if encodeUtf8 hexResponse == expected
              then do
                -- Success!!
                runDB $ delete tokenId
-                return $ Right savedUserId
+                return $ Right $ (entityKey $ fromJust mqueriedUser)
              else
                return $ Left ("Wrong password" :: T.Text)
          Nothing ->
@ -85,9 +86,9 @@ postLoginR = do
        Left msg ->
          returnJsonError msg
        Right userId -> do
-          setSession "userId" $ extractKey (fromJust userId)
+          setSession "userId" $ extractKey userId
          setMessage "Succesfully logged in"
-          welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender
+          welcomeLink <- ($ProfileR userId) <$> getUrlRender
          returnJson ["welcome" .= welcomeLink]
    _ ->
      returnJsonError ("Protocol error" :: T.Text)
--- a/Handler/Medium.hs
+++ b/Handler/Medium.hs
@ -107,7 +107,7 @@ postMediumR mediumId = do
              redirect $ MediumR mediumId
        Nothing -> do
          setMessage "You need to be looged in to comment on media"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This image does not exist"
      redirect HomeR
@ -141,7 +141,7 @@ getCommentReplyR commentId = do
            $(widgetFile "commentReply")
        Nothing -> do
          setMessage "You need to be logged in to comment on media"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This comment does not Exist"
      redirect HomeR
@ -198,7 +198,7 @@ postCommentReplyR commentId = do
              redirect $ CommentReplyR commentId
        Nothing -> do
          setMessage "You need to be logged in to post replies"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This comment does not exist!"
      redirect HomeR
@ -223,7 +223,7 @@ getCommentDeleteR commentId = do
              redirect $ MediumR $ commentOrigin comment
        Nothing -> do
          setMessage "You must be logged in to delete comments"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This comment does not exist"
      redirect HomeR
@ -261,7 +261,7 @@ postCommentDeleteR commentId = do
              redirect $ MediumR $ commentOrigin comment
        Nothing -> do
          setMessage "You must be logged in to delete comments"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This comment does not exist"
      redirect HomeR
--- a/Handler/NewAlbum.hs
+++ b/Handler/NewAlbum.hs
@ -37,7 +37,7 @@ getNewAlbumR = do
        $(widgetFile "newAlbum")
    Nothing -> do
      setMessage "You need to be logged in"
-      redirect LoginR
+      redirect $ AuthR LoginR

 postNewAlbumR :: Handler Html
 postNewAlbumR = do
@ -74,7 +74,7 @@ postNewAlbumR = do
          redirect NewAlbumR
    Nothing -> do
      setMessage "You must be logged in to create albums"
-      redirect LoginR
+      redirect $ AuthR LoginR

 albumForm :: UserId -> AForm Handler Album
 albumForm userId = Album
--- a/Handler/ProfileSettings.hs
+++ b/Handler/ProfileSettings.hs
@ -70,6 +70,7 @@ profileSettingsForm user = User
  <*> pure (userAdmin user)
  <*> areq (selectField licences) (bfs ("Default licence for media" :: T.Text))
    (Just $ userDefaultLicence user)
+  <*> pure (userActive user)
  <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
  where
    licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
--- a/Handler/Reactivate.hs
+++ b/Handler/Reactivate.hs
@ -37,7 +37,7 @@ postReactivateR = do
        then do
          userTokens <- foldM (\userTokens (Entity userId user) -> do
            token <- liftIO $ generateString
-            _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId)
+            _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (userName user)
            return $ (user, token) : userTokens
            ) [] users
          _ <- foldM (\sent (user, token) ->
--- a/Handler/Signup.hs
+++ b/Handler/Signup.hs
@ -64,7 +64,7 @@ postSignupR = do
          let newUser = User newUserName newUserName (fromJust mEmail) salt "" [] False (fromEnum AllRightsReserved)
          activatorText <- liftIO generateString
          _ <- runDB $ insert $ Activator activatorText newUser
-          _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
+          _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" newUserName
          activateLink <- ($ ActivateR activatorText) <$> getUrlRender
          sendMail (userEmail newUser) "Please activate your account!" $
            [shamlet|
--- a/Handler/Upload.hs
+++ b/Handler/Upload.hs
@ -61,7 +61,7 @@ getDirectUploadR albumId = do
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to upload"
-          redirect LoginR
+          redirect $ AuthR LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR
@ -168,7 +168,7 @@ getUploadR = do
            $(widgetFile "bulkUpload")
    Nothing -> do
      setMessage "You need to be logged in"
-      redirect LoginR
+      redirect $ AuthR LoginR

 bulkUploadForm :: UserId -> User -> AForm Handler FileBulk
 bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h)
@ -234,4 +234,4 @@ postUploadR = do
          redirect UploadR
    Nothing -> do
      setMessage "You need to be logged in"
-      redirect LoginR
+      redirect $ AuthR LoginR
--- a/Import.hs
+++ b/Import.hs
@ -21,6 +21,7 @@ module Import
 import           Prelude              as Import hiding (head, init, last,
                                                 readFile, tail, writeFile)
 import           Yesod                as Import hiding (Route (..))
+import           Yesod.Auth           as Import
 import           Yesod.Static         as Import
 import           Yesod.Form.Bootstrap3 as Import

--- a/config/models
+++ b/config/models
@ -23,6 +23,7 @@ User
    albums [AlbumId]
    admin Bool
    defaultLicence Int		default=-1
+    active Bool			default=True
    UniqueUser name
    deriving Typeable Eq Show
 Activator
@ -32,7 +33,8 @@ Activator
 Token
    token ByteString
    kind Text
-    user UserId Maybe
+    username Text
+    UniqueToken token
    deriving Eq Show
 Album
    title Text
--- a/config/routes
+++ b/config/routes
@ -15,18 +15,20 @@
 --  along with this program.  If not, see <http://www.gnu.org/licenses/>.

 /static StaticR Static appStatic
+/auth AuthR Auth getAuth

 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET

 /				HomeR			GET
 /page/#Int			PageR			GET
-/signup				SignupR			GET POST
-/login				LoginR			GET POST
-/loginraw			LoginRawR		POST
-/logout				LogoutR			GET
-/activate/#T.Text		ActivateR		GET POST
-/activateraw/#T.Text		ActivateRawR		POST
+-- /signup				SignupR			GET POST
+-- /login				LoginR			GET POST
+-- /loginraw			LoginRawR		POST
+-- /logout				LogoutR			GET
+-- /activate/#T.Text		ActivateR		GET POST
+-- /activateraw/#T.Text		ActivateRawR		POST
+-- /reactivate			ReactivateR		GET POST
 /profile/#UserId		ProfileR		GET
 /user/#T.Text			UserR			GET
 /user/#T.Text/album/#T.Text	BeautyAlbumR		GET
@ -42,7 +44,6 @@
 /medium/#MediumId/move          MediumMoveR             GET POST
 /comment/#CommentId/reply	CommentReplyR		GET POST
 /comment/#CommentId/delcom	CommentDeleteR		GET POST
-/reactivate			ReactivateR		GET POST
 /profile/#UserId/settings	ProfileSettingsR	GET POST
 /profile/#UserId/delete		ProfileDeleteR		GET POST

--- a/eidolon.cabal
+++ b/eidolon.cabal
@ -31,9 +31,10 @@ library
                     Settings.StaticFiles
                     Settings.Development
                     Handler.Home
-                     Handler.Signup
-                     Handler.Login
-                     Handler.Activate
+                     -- Handler.Signup
+                     -- Handler.Login
+                     -- Handler.Activate
+                     -- Handler.Reactivate
                     Handler.Profile
                     Handler.Upload
                     Handler.NewAlbum
@ -41,7 +42,6 @@ library
                     Handler.Medium
                     Handler.AlbumSettings
                     Handler.MediumSettings
-                     Handler.Reactivate
                     Handler.ProfileSettings
                     Handler.ProfileDelete
                     Handler.Admin
@ -142,6 +142,8 @@ library
                 , yesod-form                    >= 1.4.7
                 , magic
                 , texmath < 0.9
+                 , yesod-auth
+                 , yesod-auth-hmac-keccak

 executable         eidolon
    if flag(library-only)
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@ -5,7 +5,7 @@
        <li>
          <a href=@{HomeR}>
            Home
-        $maybe _ <- msu
+        $maybe username <- musername
          <li>
            <label for="cb1">
              <a>
@ -22,20 +22,19 @@
                <a href=@{UploadR}>
                  Upload images
              <li>
-                <a href=@{LogoutR}>
+                <a href=@{AuthR LogoutR}>
                  Logout
-              $maybe admin <- madmin
-                $if admin
-                  <li>
-                    <a href=@{AdminR} .red>
-                      Administration
+              $if admin
+                <li>
+                  <a href=@{AdminR} .red>
+                    Administration
        $nothing
          <li>
-            <a href=@{LoginR}>
+            <a href=@{AuthR LoginR}>
              Login
          $if block == False
            <li>
-              <a href=@{SignupR}>
+              <a href=@{AuthR newAccountR}>
                Signup
    <!--<div .col-md-3 .col-sm-6 #search>
      ^{pageBody searchWidget}-->