diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.3.0.0 +======= + +* Add authorisation by single usage codes. + 0.2.0.1 ======= diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal --- a/servant-auth-token.cabal +++ b/servant-auth-token.cabal @@ -1,5 +1,5 @@ name: servant-auth-token -version: 0.2.0.1 +version: 0.3.0.0 synopsis: Servant based API and server for token based authorisation description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme @@ -18,6 +18,7 @@ library hs-source-dirs: src exposed-modules: + Servant.Server.Auth.Token Servant.Server.Auth.Token.Common Servant.Server.Auth.Token.Config Servant.Server.Auth.Token.Error @@ -26,7 +27,7 @@ Servant.Server.Auth.Token.Pagination Servant.Server.Auth.Token.Patch Servant.Server.Auth.Token.Restore - Servant.Server.Auth.Token + Servant.Server.Auth.Token.SingleUse build-depends: base >= 4.7 && < 5 , aeson-injector >= 1.0.4 && < 1.1 @@ -37,7 +38,7 @@ , persistent-postgresql >= 2.2 && < 2.6 , persistent-template >= 2.1 && < 2.6 , pwstore-fast >= 2.4 && < 2.5 - , servant-auth-token-api >= 0.2.0 && < 0.3 + , servant-auth-token-api >= 0.3.0 && < 0.4 , servant-server >= 0.7 && < 0.9 , text >= 1.2 && < 1.3 , time >= 1.5 && < 1.7 diff --git a/src/Servant/Server/Auth/Token.hs b/src/Servant/Server/Auth/Token.hs --- a/src/Servant/Server/Auth/Token.hs +++ b/src/Servant/Server/Auth/Token.hs @@ -70,6 +70,8 @@ , authUserByToken -- * API methods , authSignin + , authSigninGetCode + , authSigninPostCode , authTouch , authToken , authSignout @@ -80,12 +82,15 @@ , authUserPut , authUserDelete , authRestore + , authGetSingleUseCodes , authGroupGet , authGroupPost , authGroupPut , authGroupPatch , authGroupDelete , authGroupList + -- * Low-level API + , getAuthToken ) where import Control.Monad @@ -111,6 +116,7 @@ import Servant.Server.Auth.Token.Monad import Servant.Server.Auth.Token.Pagination import Servant.Server.Auth.Token.Restore +import Servant.Server.Auth.Token.SingleUse import qualified Data.ByteString.Lazy as BS @@ -123,7 +129,7 @@ convertAuthHandler cfg = Nat (flip runReaderT cfg . runAuthHandler) -- | The interface your application should implement to be able to use --- token aurhorisation API. +-- token authorisation API. class Monad m => AuthMonad m where getAuthConfig :: m AuthConfig liftAuthAction :: ExceptT ServantErr IO a -> m a @@ -143,6 +149,8 @@ authServer :: AuthConfig -> Server AuthAPI authServer cfg = enter (convertAuthHandler cfg) ( authSignin + :<|> authSigninGetCode + :<|> authSigninPostCode :<|> authTouch :<|> authToken :<|> authSignout @@ -153,6 +161,7 @@ :<|> authUserPut :<|> authUserDelete :<|> authRestore + :<|> authGetSingleUseCodes :<|> authGroupGet :<|> authGroupPost :<|> authGroupPut @@ -165,16 +174,12 @@ => Maybe Login -- ^ Login query parameter -> Maybe Password -- ^ Password query parameter -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid - -> m (OnlyField "token" SimpleToken) -- ^ If everthing is OK, return token + -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token authSignin mlogin mpass mexpire = runAuth $ do login <- require "login" mlogin pass <- require "pass" mpass Entity uid UserImpl{..} <- guardLogin login pass - expire <- calcExpire mexpire - mt <- getExistingToken uid -- check whether there is already existing token - OnlyField <$> case mt of - Nothing -> createToken uid expire -- create new token - Just t -> touchToken t expire -- prolong token expiration time + OnlyField <$> getAuthToken uid mexpire where guardLogin login pass = do -- check login and password, return passed user muser <- runDB $ selectFirst [UserImplLogin ==. login] [] @@ -185,11 +190,23 @@ then return user else err - getExistingToken uid = do -- return active token for specified user id +-- | Helper to get or generate new token for user +getAuthToken :: AuthMonad m + => UserImplId -- ^ User for whom we want token + -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default + -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one +getAuthToken uid mexpire = runAuth $ do + expire <- calcExpire mexpire + mt <- getExistingToken -- check whether there is already existing token + case mt of + Nothing -> createToken expire -- create new token + Just t -> touchToken t expire -- prolong token expiration time + where + getExistingToken = do -- return active token for specified user id t <- liftIO getCurrentTime runDB $ selectFirst [AuthTokenUser ==. uid, AuthTokenExpire >. t] [] - createToken uid expire = do -- generate and save fresh token + createToken expire = do -- generate and save fresh token token <- toText <$> liftIO nextRandom _ <- runDB $ insert AuthToken { authTokenValue = token @@ -198,6 +215,90 @@ } return token +-- | Authorisation via code of single usage. +-- +-- Implementation of 'AuthSigninGetCodeMethod' endpoint. +-- +-- Logic of authorisation via this method is: +-- +-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint +-- +-- * Server generates single use token and sends it via +-- SMS or email, defined in configuration by 'singleUseCodeSender' field. +-- +-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint +-- +-- * Server responds with auth token. +-- +-- * Client uses the token with other requests as authorisation +-- header +-- +-- * Client can extend lifetime of token by periodically pinging +-- of 'AuthTouchMethod' endpoint +-- +-- * Client can invalidate token instantly by 'AuthSignoutMethod' +-- +-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. +-- +-- See also: 'authSigninPostCode' +authSigninGetCode :: AuthMonad m + => Maybe Login -- ^ User login, required + -> m Unit +authSigninGetCode mlogin = runAuth $ do + login <- require "login" mlogin + uinfo <- runDB404 "user" $ readUserInfoByLogin login + let uid = toKey $ respUserId uinfo + + AuthConfig{..} <- getConfig + code <- liftIO singleUseCodeGenerator + expire <- makeSingleUseExpire singleUseCodeExpire + runDB $ registerSingleUseCode uid code (Just expire) + liftIO $ singleUseCodeSender uinfo code + + return Unit + +-- | Authorisation via code of single usage. +-- +-- Logic of authorisation via this method is: +-- +-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint +-- +-- * Server generates single use token and sends it via +-- SMS or email, defined in configuration by 'singleUseCodeSender' field. +-- +-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint +-- +-- * Server responds with auth token. +-- +-- * Client uses the token with other requests as authorisation +-- header +-- +-- * Client can extend lifetime of token by periodically pinging +-- of 'AuthTouchMethod' endpoint +-- +-- * Client can invalidate token instantly by 'AuthSignoutMethod' +-- +-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. +-- +-- See also: 'authSigninGetCode' +authSigninPostCode :: AuthMonad m + => Maybe Login -- ^ User login, required + -> Maybe SingleUseCode -- ^ Received single usage code, required + -> Maybe Seconds + -- ^ Time interval after which the token expires, 'Nothing' means + -- some default value + -> m (OnlyField "token" SimpleToken) +authSigninPostCode mlogin mcode mexpire = runAuth $ do + login <- require "login" mlogin + code <- require "code" mcode + + uinfo <- runDB404 "user" $ readUserInfoByLogin login + let uid = toKey $ respUserId uinfo + isValid <- runDB $ validateSingleUseCode uid code + unless isValid $ throw401 "Single usage code doesn't match" + + OnlyField <$> getAuthToken uid mexpire + -- | Calculate expiration timestamp for token calcExpire :: Maybe Seconds -> AuthHandler UTCTime calcExpire mexpire = do @@ -383,6 +484,21 @@ user' <- setUserPassword pass user runDB $ replace uid user' return Unit + +-- | Implementation of 'AuthGetSingleUseCodes' endpoint. +authGetSingleUseCodes :: AuthMonad m + => UserId -- ^ Id of user + -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes. + -- And server can define maximum count of codes that user can have at once. + -> MToken' '["auth-single-codes"] + -> m (OnlyField "codes" [SingleUseCode]) +authGetSingleUseCodes uid mcount token = runAuth $ do + guardAuthToken token + let uid' = toKey uid + _ <- runDB404 "user" $ readUserInfo uid + AuthConfig{..} <- getConfig + let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount + runDB $ OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n -- | Getting user by id, throw 404 response if not found guardUser :: UserImplId -> AuthHandler UserImpl diff --git a/src/Servant/Server/Auth/Token/Config.hs b/src/Servant/Server/Auth/Token/Config.hs --- a/src/Servant/Server/Auth/Token/Config.hs +++ b/src/Servant/Server/Auth/Token/Config.hs @@ -59,6 +59,29 @@ , servantErrorFormer :: !(ServantErr -> ServantErr) -- | Default size of page for pagination , defaultPageSize :: !Word + -- | User specified method of sending single usage code for authorisation. + -- + -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'. + -- + -- By default does nothing. + , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ()) + -- | Time the generated single usage code expires after. + -- + -- By default 1 hour. + , singleUseCodeExpire :: !NominalDiffTime + -- | User specified generator for single use codes. + -- + -- By default the server generates UUID that can be unacceptable for SMS way of sending. + , singleUseCodeGenerator :: !(IO SingleUseCode) + -- | Number of not expiring single use codes that user can have at once. + -- + -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100. + , singleUseCodePermamentMaximum :: !Word + -- | Number of not expiring single use codes that generated by default when client doesn't + -- specify the value. + -- + -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20. + , singleUseCodeDefaultCount :: !Word } -- | Default configuration for authorisation server @@ -74,8 +97,17 @@ , passwordValidator = const Nothing , servantErrorFormer = id , defaultPageSize = 50 + , singleUseCodeSender = const $ const $ return () + , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour + , singleUseCodeGenerator = uuidSingleUseCodeGenerate + , singleUseCodePermamentMaximum = 100 + , singleUseCodeDefaultCount = 20 } -- | Default generator of restore codes uuidCodeGenerate :: IO RestoreCode uuidCodeGenerate = toText <$> liftIO nextRandom + +-- | Default generator of restore codes +uuidSingleUseCodeGenerate :: IO RestoreCode +uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom diff --git a/src/Servant/Server/Auth/Token/Model.hs b/src/Servant/Server/Auth/Token/Model.hs --- a/src/Servant/Server/Auth/Token/Model.hs +++ b/src/Servant/Server/Auth/Token/Model.hs @@ -19,6 +19,7 @@ , AuthUserGroupUsers(..) , AuthUserGroupPerms(..) , EntityField(..) + , UserSingleUseCode(..) -- * IDs of entities , UserImplId , UserPermId @@ -27,6 +28,7 @@ , AuthUserGroupId , AuthUserGroupUsersId , AuthUserGroupPermsId + , UserSingleUseCodeId -- * Operations , runDB , migrateAll @@ -35,6 +37,7 @@ -- ** User , userToUserInfo , readUserInfo + , readUserInfoByLogin , getUserPermissions , setUserPermissions , createUser @@ -109,6 +112,13 @@ expire UTCTime deriving Generic Show +UserSingleUseCode + value SingleUseCode + user UserImplId + expire UTCTime Maybe -- Nothing is code that never expires + used UTCTime Maybe + deriving Generic Show + AuthUserGroup name Text parent AuthUserGroupId Maybe @@ -149,18 +159,26 @@ , respUserGroups = groups } +-- | Low level operation for collecting info about user +makeUserInfo :: Entity UserImpl -> SqlPersistT IO RespUserInfo +makeUserInfo euser = do + let uid = entityKey euser + perms <- getUserPermissions uid + groups <- getUserGroups uid + return $ userToUserInfo euser perms groups + -- | Get user by id readUserInfo :: UserId -> SqlPersistT IO (Maybe RespUserInfo) readUserInfo uid' = do let uid = toKey uid' muser <- get uid - case muser of - Nothing -> return Nothing - Just user -> do - perms <- getUserPermissions uid - groups <- getUserGroups uid - return . Just $ - userToUserInfo (Entity uid user) perms groups + maybe (return Nothing) (fmap Just . makeUserInfo . Entity uid) $ muser + +-- | Get user by login +readUserInfoByLogin :: Login -> SqlPersistT IO (Maybe RespUserInfo) +readUserInfoByLogin login = do + muser <- getBy $ UniqueLogin login + maybe (return Nothing) (fmap Just . makeUserInfo) muser -- | Return list of permissions for the given user (only permissions that are assigned to him directly) getUserPermissions :: UserImplId -> SqlPersistT IO [Permission] diff --git a/src/Servant/Server/Auth/Token/SingleUse.hs b/src/Servant/Server/Auth/Token/SingleUse.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/SingleUse.hs @@ -0,0 +1,85 @@ +{-| +Module : Servant.Server.Auth.Token.SingleUse +Description : Specific functions to work with single usage codes. +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.SingleUse( + makeSingleUseExpire + , registerSingleUseCode + , invalideSingleUseCode + , validateSingleUseCode + , generateSingleUsedCodes + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Time +import Database.Persist.Sql +import Servant.API.Auth.Token +import Servant.Server.Auth.Token.Common +import Servant.Server.Auth.Token.Model + +-- | Calculate expire date for single usage code +makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code + -> m UTCTime -- ^ Time when the code expires +makeSingleUseExpire dt = do + t <- liftIO getCurrentTime + return $ dt `addUTCTime` t + +-- | Register single use code in DB +registerSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user + -> SingleUseCode -- ^ Single usage code + -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code + -> SqlPersistT m () +registerSingleUseCode uid code expire = void $ insert + $ UserSingleUseCode code uid expire Nothing + +-- | Marks single use code that it cannot be used again +invalideSingleUseCode :: MonadIO m => UserSingleUseCodeId -- ^ Id of code + -> SqlPersistT m () +invalideSingleUseCode i = do + t <- liftIO getCurrentTime + update i [UserSingleUseCodeUsed =. Just t] + +-- | Check single use code and return 'True' on success. +-- +-- On success invalidates single use code. +validateSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user + -> SingleUseCode -- ^ Single usage code + -> SqlPersistT m Bool +validateSingleUseCode uid code = do + t <- liftIO getCurrentTime + mcode <- selectFirst ([ + UserSingleUseCodeValue ==. code + , UserSingleUseCodeUser ==. uid + , UserSingleUseCodeUsed ==. Nothing + ] ++ ( + [UserSingleUseCodeExpire ==. Nothing] + ||. [UserSingleUseCodeExpire >=. Just t] + )) [Desc UserSingleUseCodeExpire] + whenJust mcode $ invalideSingleUseCode . entityKey + return $ maybe False (const True) mcode + +-- | Generates a set single use codes that doesn't expire. +-- +-- Note: previous codes without expiration are invalidated. +generateSingleUsedCodes :: MonadIO m => UserImplId -- ^ Id of user + -> IO SingleUseCode -- ^ Generator of codes + -> Word -- Count of codes + -> SqlPersistT m [SingleUseCode] +generateSingleUsedCodes uid gen n = do + t <- liftIO getCurrentTime + updateWhere [ + UserSingleUseCodeUser ==. uid + , UserSingleUseCodeUsed ==. Nothing + , UserSingleUseCodeExpire ==. Nothing + ] + [UserSingleUseCodeUsed =. Just t] + replicateM (fromIntegral n) $ do + code <- liftIO gen + _ <- insert $ UserSingleUseCode code uid Nothing Nothing + return code