servant-auth-token 0.2.0.1 → 0.3.0.0

raw patch · 6 files changed

+276/−19 lines, 6 filesdep ~servant-auth-token-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: servant-auth-token-api

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• servant-auth-token.cabal +4/−3
• src/Servant/Server/Auth/Token.hs +125/−9
• src/Servant/Server/Auth/Token/Config.hs +32/−0
• src/Servant/Server/Auth/Token/Model.hs +25/−7
• src/Servant/Server/Auth/Token/SingleUse.hs +85/−0

@@ -1,3 +1,8 @@+0.3.0.0+=======++* Add authorisation by single usage codes.+ 0.2.0.1 ======= 

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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