yesod-auth-hmac-keccak 0.0.0.4 → 0.0.0.5

raw patch · 2 files changed

+99/−115 lines, 2 filesdep ~yesod-core

Dependency ranges changed: yesod-core

Files

• hssrc/Yesod/Auth/HmacKeccak.hs +97/−113
• yesod-auth-hmac-keccak.cabal +2/−2

@@ -1,5 +1,6 @@ {-# LANGUAGE   CPP+, RankNTypes , OverloadedStrings , RecordWildCards , QuasiQuotes@@ -29,18 +30,14 @@ import qualified Database.Persist as P  import System.Random-import System.IO.Unsafe (unsafePerformIO)  import Numeric (readHex, showHex) -import Yesod.Auth import Yesod.Auth.Message-import Yesod.Persist hiding (get, replace, insertkey, Entity, entityVal)-import Yesod.Static+import Yesod.Persist hiding (get, replace, Entity, entityVal)  import Text.Julius (jsFile) -import Paths_yesod_auth_hmac_keccak as Paths import Yesod.Auth.JsPath  -- | type alias@@ -57,7 +54,7 @@    -- | function for accessing the database (runDB eqivalent).   -- can be set to 'runHmacPersistDB'-  runHmacDB :: db a -> HandlerT master IO a+  runHmacDB :: db a -> AuthHandler master a   -- runHmacDB = runHmacPersistDB    -- | function to determine a valid username.@@ -68,22 +65,22 @@    -- | Handler for rendering the registration page.   -- Default: 'getNewAccountR''-  getNewAccountR :: HandlerT Auth (HandlerT master IO) Html+  getNewAccountR :: AuthHandler master Html   getNewAccountR = getNewAccountR'    -- | Handler for processing registration.   -- Default: 'postNewAccountR''-  postNewAccountR :: HandlerT Auth (HandlerT master IO) Html+  postNewAccountR :: AuthHandler master Html   postNewAccountR = postNewAccountR'    -- | Handler for rendering reactivation request page.   -- Default: 'getReactivateR''-  getReactivateR :: HandlerT Auth (HandlerT master IO) Html+  getReactivateR :: AuthHandler master Html   getReactivateR = getReactivateR'    -- | Handler for processing reactivation requests.   -- Default: 'postReactivateR''-  postReactivateR :: HandlerT Auth (HandlerT master IO) Html+  postReactivateR :: AuthHandler master Html   postReactivateR = postReactivateR'    -- | Function for rendering all messages in this plugin.@@ -93,14 +90,14 @@    -- | Route for providing login without javascript.   -- Default: 'Nothing'-  rawLoginRoute :: Maybe (Route (HandlerSite (WidgetT master IO)))+  rawLoginRoute :: Maybe (Route (HandlerSite (WidgetFor master)))   rawLoginRoute = Nothing    -- | Widget for the login page.   -- Default: 'defaultLoginWidget'   loginWidget     :: YesodHmacKeccak db master-    => (Route Auth -> Route master) -> WidgetT master IO ()+    => (Route Auth -> Route master) -> WidgetFor master ()   loginWidget = defaultLoginWidget  hmacPlugin@@ -134,7 +131,7 @@ -- | Overridable default login widget defaultLoginWidget     :: YesodHmacKeccak db master-    => (Route Auth -> Route master) -> WidgetT master IO ()+    => (Route Auth -> Route master) -> WidgetFor master () defaultLoginWidget tm = do   render <- getUrlRenderParams   toWidgetHead $ $(jsFile jsPath) render@@ -173,22 +170,22 @@   :: ( YesodHmacKeccak db master      , YesodAuth master      )-  => HandlerT Auth (HandlerT master IO) RepJson+  => AuthHandler master RepJson postLoginR' = do-  mr <- lift getMessageRender+  mr <- getMessageRender   mUserName <- lookupPostParam "username"   mHexToken <- lookupPostParam "token"   mHexResponse <- lookupPostParam "response"   case (mUserName, mHexToken, mHexResponse) of     (Just userName, Nothing, Nothing) -> do-      tempUser <- lift $ runHmacDB $ loadUser userName+      tempUser <- runHmacDB $ loadUser userName       case tempUser of         Just u ->           if userUserActive u           then do             let salt = userUserSalt u             token <- liftIO makeRandomToken-            lift $ runHmacDB $ insertLoginToken (encodeUtf8 token) userName+            _ <- runHmacDB $ insertLoginToken (encodeUtf8 token) userName             returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)]           else do             returnJsonError (mr MsgUserNotActive)@@ -197,10 +194,10 @@     (Nothing, Just hexToken, Just hexResponse) -> do       response <- do         let tempToken = fromHex' $ T.unpack hexToken-        savedToken <- lift $ runHmacDB $ loadLoginToken tempToken+        savedToken <- runHmacDB $ loadLoginToken tempToken         case savedToken of           Just token -> do-            queriedUser <- lift $ runHmacDB $ loadUser (tokenTokenUsername token)+            queriedUser <- runHmacDB $ loadUser (tokenTokenUsername token)             let salted = userUserSalted $ fromJust queriedUser                 hexSalted = toHex salted                 expected =@@ -210,7 +207,7 @@             if encodeUtf8 hexResponse == expected             then do               -- SUCCESS !!-              lift $ runHmacDB $ deleteToken token+              runHmacDB $ deleteToken token               return $ Right $ fromJust queriedUser             else               return $ Left (mr MsgWrongPassword)@@ -219,9 +216,9 @@       case response of         Left msg -> returnJsonError msg         Right au -> do-          lift $ setCreds False $ Creds "authHmacKeccak" (userUserName au) []-          render <- lift getUrlRender-          m <- lift getYesod+          setCreds False $ Creds "authHmacKeccak" (userUserName au) []+          render <- getUrlRender+          m <- getYesod           let u = render (loginDest m)           returnJson ["welcome" .= u]     _ ->@@ -248,11 +245,11 @@  newAccountWidget   :: YesodHmacKeccak db master-  => (Route Auth -> Route master) -> WidgetT master IO ()+  => (Route Auth -> Route master) -> WidgetFor master () newAccountWidget tm = do   render <- getUrlRenderParams   toWidgetHead $ $(jsFile jsPath) render-  ((_, widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs newAccountForm+  ((_, widget), enctype) <- runFormPost $ renderDivs newAccountForm   [whamlet| <div .newaccount>   <form method="post" enctype=#{enctype} action=@{tm newAccountR}>@@ -262,36 +259,36 @@  getNewAccountR'   :: YesodHmacKeccak db master-  => HandlerT Auth (HandlerT master IO) Html+  => AuthHandler master Html getNewAccountR' = do   tm <- getRouteToParent-  lift $ defaultLayout $ do+  authLayout $ do     setTitleI MsgRegisterLong     newAccountWidget tm  postNewAccountR'   :: YesodHmacKeccak db master-  => HandlerT Auth (HandlerT master IO) Html+  => AuthHandler master Html postNewAccountR' = do+  ((result, _), _) <- runFormPost $ renderDivs newAccountForm   tm <- getRouteToParent-  ((result, _), _) <- lift $ runFormPost $ renderDivs newAccountForm   case result of     FormMissing -> invalidArgs ["Form is missing"]     FormFailure msg -> do       setMessage $ toHtml $ T.concat msg-      redirect newAccountR+      redirect $ tm newAccountR     FormSuccess d -> do-      lift $ setMessageI MsgActivationSent-      lift $ createNewAccount d tm-      redirect LoginR+      setMessageI MsgActivationSent+      _ <- createNewAccount d+      redirect $ tm LoginR  createNewAccount   :: YesodHmacKeccak db master   => NewAccountData-  -> (Route Auth -> Route master)-  -> HandlerT master IO (UserAccount db)-createNewAccount nad@NewAccountData{..} tm = do+  -> AuthHandler master (UserAccount db)+createNewAccount NewAccountData{..} = do   muser <- runHmacDB $ loadUser naUsername+  tm <- getRouteToParent   case muser of     Just _ -> do       setMessageI $ MsgUsernameExists naUsername@@ -334,13 +331,14 @@  passwordWidget   :: YesodHmacKeccak db master-  => (Route Auth -> Route master) -> ByteString -> ByteString -> WidgetT master IO ()+  => (Route Auth -> Route master)+  -> ByteString -> ByteString -> WidgetFor master () passwordWidget tm token hexSalt= do   render <- getUrlRenderParams   toWidgetHead $ $(jsFile jsPath) render   [whamlet| <div .password>-  <form #activateform method=post action=@{tm $ verifyR token}>+  <form #activateform method=post action=@{tm (verifyR token)}>     <div .required>       <label for="password1">_{MsgPassword1}:       <input #password1 type="password" required>@@ -360,54 +358,55 @@  getVerifyR'   :: YesodHmacKeccak db master-  => ByteString -> HandlerT Auth (HandlerT master IO) Html+  => ByteString -> AuthHandler master Html getVerifyR' k = do-  mtoken <- lift $ runHmacDB $ loadActivateToken k+  mtoken <- runHmacDB $ loadActivateToken k+  tm <- getRouteToParent   case mtoken of     Nothing -> do-      lift $ setMessageI MsgInvalidToken-      redirect LoginR+      setMessageI MsgInvalidToken+      redirect $ tm LoginR     Just token -> do-      muser <- lift $ runHmacDB $ loadUser $ tokenTokenUsername token+      muser <- runHmacDB $ loadUser $ tokenTokenUsername token       case muser of         Nothing -> do-          lift $ setMessageI MsgNoSuchUser-          redirect LoginR+          setMessageI MsgNoSuchUser+          redirect $ tm LoginR         Just user -> do           let hexSalt = toHex $ userUserSalt user-          tm <- getRouteToParent-          lift $ defaultLayout $ do+          authLayout $ do             setTitleI MsgSetPassword             passwordWidget tm (tokenTokenToken token) (BC.pack $ T.unpack hexSalt)  postVerifyR'   :: YesodHmacKeccak db master-  => ByteString -> HandlerT Auth (HandlerT master IO) RepJson+  => ByteString -> AuthHandler master RepJson postVerifyR' k = do-  mtoken <- lift $ runHmacDB $ loadActivateToken k+  mtoken <- runHmacDB $ loadActivateToken k+  tm <- getRouteToParent   case mtoken of     Nothing -> do-      lift $ setMessageI MsgInvalidToken-      redirect LoginR+      setMessageI MsgInvalidToken+      redirect $ tm LoginR     Just token -> do-      muser <- lift $ runHmacDB $ loadUser $ tokenTokenUsername token+      muser <- runHmacDB $ loadUser $ tokenTokenUsername token       case muser of         Nothing -> do-          lift $ setMessageI MsgNoSuchUser-          redirect LoginR+          setMessageI MsgNoSuchUser+          redirect $ tm LoginR         Just user -> do           msalted <- lookupPostParam "salted"           case msalted of             Nothing -> do-              lift $ setMessageI MsgProtocolError-              redirect LoginR+              setMessageI MsgProtocolError+              redirect $ tm LoginR             Just salted' -> do               let salted = fromHex' $ T.unpack salted'-              lift $ runHmacDB $ activateUser user salted-              lift $ runHmacDB $ deleteToken token-              lift $ setCreds False $ Creds "authHmacKeccak" (tokenTokenUsername token) []-              render <- lift getUrlRender-              m <- lift getYesod+              runHmacDB $ activateUser user salted+              runHmacDB $ deleteToken token+              setCreds False $ Creds "authHmacKeccak" (tokenTokenUsername token) []+              render <- getUrlRender+              m <- getYesod               let u = render (loginDest m)               returnJson ["welcome" .= u] @@ -424,11 +423,11 @@  reactivateWidget   :: YesodHmacKeccak db master-  => (Route Auth -> Route master) -> WidgetT master IO ()+  => (Route Auth -> Route master) -> WidgetFor master () reactivateWidget tm = do   render <- getUrlRenderParams   toWidgetHead $ $(jsFile jsPath) render-  ((_, widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs reactivateForm+  ((_, widget), enctype) <- runFormPost $ renderDivs reactivateForm   [whamlet| <div .reactivate>   <form method="post" enctype=#{enctype} action=@{tm resetPasswordR}>@@ -438,38 +437,39 @@  getReactivateR'   :: YesodHmacKeccak db master-  => HandlerT Auth (HandlerT master IO) Html+  => AuthHandler master Html getReactivateR' = do   tm <- getRouteToParent-  lift $ defaultLayout $ do+  authLayout $ do     setTitleI MsgPasswordReset     reactivateWidget tm  postReactivateR'   :: YesodHmacKeccak db master-  => HandlerT Auth (HandlerT master IO) Html+  => AuthHandler master Html postReactivateR' = do-  ((result, _), _) <- lift $ runFormPost $ renderDivs reactivateForm+  ((result, _), _) <- runFormPost $ renderDivs reactivateForm+  tm <- getRouteToParent   case result of     FormMissing -> invalidArgs ["Form is missing"]     FormFailure msg -> do-      lift $ setMessage $ toHtml $ T.concat msg-      redirect LoginR+      setMessage $ toHtml $ T.concat msg+      redirect $ tm LoginR     FormSuccess uname -> do-      muser <- lift $ runHmacDB $ loadUser uname+      muser <- runHmacDB $ loadUser uname       case muser of         Nothing -> do-          lift $ setMessageI MsgNoSuchUser-          redirect LoginR+          setMessageI MsgNoSuchUser+          redirect $ tm LoginR         Just user -> do           token <- liftIO makeRandomToken-          tm <- getRouteToParent-          lift $ runHmacDB $ insertActivateToken (encodeUtf8 token) uname-          render <- lift getUrlRender-          lift $ sendReactivateEmail uname (userUserEmail user) $-            render $ tm $ verifyR $ encodeUtf8 token-          lift $ setMessageI MsgActivationSent-          redirect LoginR+          _ <- runHmacDB $ insertActivateToken (encodeUtf8 token) uname+          render <- getUrlRender+          toParentRoute <- getRouteToParent+          sendReactivateEmail uname (userUserEmail user) $+            render $ toParentRoute $ verifyR $ encodeUtf8 token+          setMessageI MsgActivationSent+          redirect $ tm LoginR  -- classes and foo @@ -551,27 +551,27 @@  class HmacSendMail master where   sendVerifyEmail-    :: Username -> Text -> Text -> HandlerT master IO ()+    :: Username -> Text -> Text -> AuthHandler master ()    sendReactivateEmail-    :: Username -> Text -> Text -> HandlerT master IO ()+    :: Username -> Text -> Text -> AuthHandler master ()  instance YesodHmacKeccak db master => RenderMessage master AccountMsg where   renderMessage = renderAccountMessage  data PersistHmacFuncs master user token = PersistHmacFuncs-  { puGet :: Text -> HandlerT master IO (Maybe (Entity user))-  , puInsert :: Username -> user -> HandlerT master IO (Either Text (Entity user))-  , puUpdate :: Entity user -> [Update user] -> HandlerT master IO ()-  , ptGet :: ByteString -> Text -> HandlerT master IO (Maybe (Entity token))-  , ptInsert :: ByteString -> token -> HandlerT master IO (Either Text (Entity token))-  , ptUpdate :: Entity token -> [Update token] -> HandlerT master IO ()-  , ptDelete :: Entity token -> HandlerT master IO ()+  { puGet :: Text -> HandlerFor master (Maybe (Entity user))+  , puInsert :: Username -> user -> HandlerFor master (Either Text (Entity user))+  , puUpdate :: Entity user -> [Update user] -> HandlerFor master ()+  , ptGet :: ByteString -> Text -> HandlerFor master (Maybe (Entity token))+  , ptInsert :: ByteString -> token -> HandlerFor master (Either Text (Entity token))+  , ptUpdate :: Entity token -> [Update token] -> HandlerFor master ()+  , ptDelete :: Entity token -> HandlerFor master ()   }  newtype HmacPersistDB master user token a   = HmacPersistDB-      ( (ReaderT (PersistHmacFuncs master user token) (HandlerT master IO) a)+      ( (ReaderT (PersistHmacFuncs master user token) (HandlerFor master) a)       ) deriving (Monad, MonadIO, Functor, Applicative)  instance (Yesod master, PersistUserCredentials user, PersistToken token)@@ -643,32 +643,16 @@ hmacKeccak key msg = BC.pack $ show $ hmacGetDigest (hmac key msg :: HMAC Keccak_512)  runHmacPersistDB-  :: ( Yesod master-     , PersistQueryRead b-     , PersistToken token+  :: ( PersistEntityBackend token ~ BaseBackend (YesodPersistBackend master)+     , PersistEntityBackend user ~ BaseBackend (YesodPersistBackend master)+     , PersistToken token, PersistEntity token, PersistEntity user      , YesodPersist master-     , P.PersistEntity user      , PersistUserCredentials user-     , P.PersistEntity token-     , PersistToken token-     , b ~ YesodPersistBackend master-#if MIN_VERSION_persistent(2,1,0)-     , b ~ PersistEntityBackend user-     , b ~ PersistEntityBackend token-     , PersistUnique b-#else-     , PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend user-     , PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend token-     , P.PersistUnique (b (HandlerT master IO))-     , P.PersistQuery (b (HandlerT master IO))-#endif-#if MIN_VERSION_persistent(2,5,0)-     , b ~ BaseBackend b-#endif+     , PersistUniqueWrite (YesodPersistBackend master)      , YesodHmacKeccak db master-     , db ~ HmacPersistDB master user token-     ) => HmacPersistDB master user token a -> HandlerT master IO a-runHmacPersistDB (HmacPersistDB m) = runReaderT m funcs+     , PersistQueryRead (YesodPersistBackend master))+  => HmacPersistDB master user token a -> HandlerFor master a+runHmacPersistDB (HmacPersistDB master) = runReaderT master funcs   where funcs =           PersistHmacFuncs             { puGet = runDB . P.getBy . uniqueUsername@@ -683,7 +667,7 @@                 [ tokenTokenKindF ==. kind                 , tokenTokenTokenF ==. token                 ] []-            , ptInsert = \name t -> do { mentity <- runDB $ P.insertBy t;+            , ptInsert = \_ t -> do { mentity <- runDB $ P.insertBy t;                 mr <- getMessageRender;                 case mentity of                   Left _ -> return $ Left $ mr $ MsgInvalidToken;

@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/  name:                yesod-auth-hmac-keccak-version:             0.0.0.4+version:             0.0.0.5 synopsis:            An account authentication plugin for yesod with encrypted                      token transfer. description:         This authentication plugin for Yesod uses a challenge-response@@ -46,7 +46,7 @@                      , bytestring                      , aeson                      , cryptonite-                     , yesod-core+                     , yesod-core >= 1.6                      , yesod-form                      , yesod-auth                      , yesod-static