From 526a2e7ebc859f80ae732a88af635c9d9fde7b23 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 28 Aug 2018 22:16:13 +0300 Subject: [PATCH] (#18) Creating tokens --- ebook-manager.cabal | 1 + migrations/V1.2__User_token.sql | 1 + src/API/Users.hs | 10 ++++++++-- src/Database/Schema.hs | 21 ++++++++++++++++++++- src/Database/User.hs | 32 ++++++++++++++++++++++++++++++-- 5 files changed, 60 insertions(+), 5 deletions(-) create mode 100644 migrations/V1.2__User_token.sql diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 2d699d6..3a0a051 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -73,6 +73,7 @@ executable ebook-manager , servant-server , text , transformers + , uuid , wai , warp , x509 diff --git a/migrations/V1.2__User_token.sql b/migrations/V1.2__User_token.sql new file mode 100644 index 0000000..c3ad3ee --- /dev/null +++ b/migrations/V1.2__User_token.sql @@ -0,0 +1 @@ +alter table users add column token text null; diff --git a/src/API/Users.hs b/src/API/Users.hs index 9c2ea4e..f488831 100644 --- a/src/API/Users.hs +++ b/src/API/Users.hs @@ -5,6 +5,8 @@ {-# Language TypeOperators #-} {-# Language DuplicateRecordFields #-} {-# Language TypeApplications #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language NamedFieldPuns #-} module API.Users where import Servant @@ -40,12 +42,16 @@ instance FromJSON RegisterStatus instance FromForm RegisterForm instance ToForm RegisterForm - type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus + :<|> Auth '[SA.BasicAuth] SafeUser :> "token" :> Post '[JSON, PlainText] Token handler :: ServerT API AppM -handler = loginHandler :<|> registerHandler +handler = loginHandler :<|> registerHandler :<|> newTokenHandler + +newTokenHandler :: AuthResult SafeUser -> AppM Token +newTokenHandler = requireLoggedIn $ \SafeUser{username} -> + runDB (createToken username) loginHandler :: AuthResult SafeUser -> AppM LoginStatus loginHandler (Authenticated u) = return (LoginStatus (Just u)) diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 8084168..fcd0c98 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -3,6 +3,7 @@ {-# Language OverloadedStrings #-} {-# Language DuplicateRecordFields #-} {-# Language GeneralizedNewtypeDeriving #-} +{-# Language MultiParamTypeClasses #-} module Database.Schema where import ClassyPrelude @@ -13,6 +14,11 @@ import Database.Selda.Backend import Data.Aeson import Web.HttpApiData +import Data.UUID (UUID) +import qualified Data.UUID as UUID + +import Servant (MimeRender(..), PlainText) + -- | User type newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq) newtype HashedPassword = HashedPassword {unHashed :: ByteString} @@ -70,11 +76,24 @@ instance SqlType TagID where fromSql _ = error "fromSql: Bad tagid" defaultValue = mkLit (TagID (-1)) +newtype Token = Token { unToken :: UUID } deriving (Show, ToJSON) + +instance MimeRender PlainText Token where + mimeRender _ = UUID.toLazyASCIIBytes . unToken + +instance SqlType Token where + mkLit = LCustom . LText . UUID.toText . unToken + fromSql (SqlString x) = maybe (error "fromSql: Could not parse token") Token . UUID.fromText $ x + fromSql _ = error "fromSql: Could not parse token" + defaultValue = mkLit (Token UUID.nil) + data User pass = User { identifier :: UserID , email :: Email , username :: Username , role :: Role - , password :: pass } + , token :: Maybe Token + , password :: pass + } deriving (Show, Generic) data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic) diff --git a/src/Database/User.hs b/src/Database/User.hs index 2d789ca..7a9faab 100644 --- a/src/Database/User.hs +++ b/src/Database/User.hs @@ -2,7 +2,15 @@ {-# Language TypeApplications #-} {-# Language DataKinds #-} {-# Language TemplateHaskell #-} -module Database.User where +{-# Language FlexibleContexts #-} +module Database.User + ( Token + , insertUser + , getUser + , validateUser + , createToken + , invalidateToken ) + where import ClassyPrelude import Database @@ -14,10 +22,12 @@ import Crypto.KDF.BCrypt import Crypto.Random.Types (MonadRandom) import Control.Monad.Logger import Control.Monad (mfilter) +import qualified Data.UUID.V4 as UUID data UserExistsError = UserExistsError + insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword)) insertUser username email (PlainPassword password) = getUser' username >>= maybe insert' (const (return $ Left UserExistsError)) @@ -26,7 +36,7 @@ insertUser username email (PlainPassword password) = insertAs role = do lift $ $logInfo $ "Inserting new user as " <> pack (show role) let bytePass = encodeUtf8 password - user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass) + user <- User def email username role Nothing . HashedPassword <$> lift (hashPassword 12 bytePass) insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user) adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool @@ -58,3 +68,21 @@ getUser' name = listToMaybe . fmap fromRel <$> query q u@(_ :*: _ :*: username :*: _ ) <- select (gen users) restrict (username .== literal name) return u + +createToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m Token +createToken username = do + token <- Token <$> liftIO UUID.nextRandom + void $ update (gen users) predicate (updateToken token) + return token + where + _ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users) + predicate user = user ! pUsername .== literal username + updateToken token user= user `with` [pToken := literal (Just token)] + +invalidateToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m () +invalidateToken username = do + void $ update (gen users) predicate updateToken + where + _ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users) + predicate user = user ! pUsername .== literal username + updateToken user= user `with` [pToken := literal Nothing]