module Servant.Server.Auth.Token.LevelDB.Schema where
import Control.Concurrent.RLock
import Control.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Aeson.WithField
import Data.ByteString (ByteString)
import Data.Int
import Data.List (sort, sortBy)
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Ord
import Data.SafeCopy.Store
import Data.SafeCopy.Store.Internal
import Data.Set (Set)
import Data.Store
import Data.Text (Text)
import Data.Time
import Data.Typeable hiding (Proxy)
import Database.LevelDB
import Safe
import Servant.API.Auth.Token
import Servant.API.Auth.Token.Pagination
import Servant.Server.Auth.Token.Common
import Servant.Server.Auth.Token.Model(
UserImplId
, UserImpl(..)
, UserPermId
, UserPerm(..)
, AuthTokenId
, AuthToken(..)
, UserRestoreId
, UserRestore(..)
, UserSingleUseCodeId
, UserSingleUseCode(..)
, AuthUserGroupId
, AuthUserGroup(..)
, AuthUserGroupUsersId
, AuthUserGroupUsers(..)
, AuthUserGroupPermsId
, AuthUserGroupPerms(..)
)
import qualified Data.Foldable as F
import qualified Data.Map.Strict as M
import qualified Data.Set as S
newtype ModelId = ModelId { unModelId :: Int64 }
deriving (Show, Read, Ord, Eq)
modelId :: ModelId
modelId = ModelId 0
data Model = Model {
_modelUsers :: !(Set UserImplId)
, _modelUsersByLogin :: !(Map Login UserImplId)
, _modelUserPerms :: !(Set UserPermId)
, _modelAuthTokens :: !(Set AuthTokenId)
, _modelUserRestores :: !(Set UserRestoreId)
, _modelUserSingleUseCodes :: !(Set UserSingleUseCodeId)
, _modelAuthUserGroups :: !(Set AuthUserGroupId)
, _modelAuthUserGroupUsers :: !(Set AuthUserGroupUsersId)
, _modelAuthUserGroupPerms :: !(Set AuthUserGroupPermsId)
, _modelNextUserImplId :: !Int64
, _modelNextUserPermId :: !Int64
, _modelNextAuthTokenId :: !Int64
, _modelNextUserRestoreId :: !Int64
, _modelNextUserSingleUseCodeId :: !Int64
, _modelNextAuthUserGroupId :: !Int64
, _modelNextAuthUserGroupUserId :: !Int64
, _modelNextAuthUserGroupPermId :: !Int64
}
makeLenses ''Model
newModel :: Model
newModel = Model {
_modelUsers = mempty
, _modelUsersByLogin = mempty
, _modelUserPerms = mempty
, _modelAuthTokens = mempty
, _modelUserRestores = mempty
, _modelUserSingleUseCodes = mempty
, _modelAuthUserGroups = mempty
, _modelAuthUserGroupUsers = mempty
, _modelAuthUserGroupPerms = mempty
, _modelNextUserImplId = 0
, _modelNextUserPermId = 0
, _modelNextAuthTokenId = 0
, _modelNextUserRestoreId = 0
, _modelNextUserSingleUseCodeId = 0
, _modelNextAuthUserGroupId = 0
, _modelNextAuthUserGroupUserId = 0
, _modelNextAuthUserGroupPermId = 0
}
class Key i a | i -> a, a -> i where
encodeKey :: i -> ByteString
default encodeKey :: (SafeCopy i, Typeable i) => i -> ByteString
encodeKey i = runEncode $ do
_ <- pokeE tname
safePut i
where
tname = show $ typeRep (Proxy :: Proxy i)
instance Key AuthTokenId AuthToken
instance Key AuthUserGroupId AuthUserGroup
instance Key AuthUserGroupPermsId AuthUserGroupPerms
instance Key AuthUserGroupUsersId AuthUserGroupUsers
instance Key ModelId Model
instance Key UserImplId UserImpl
instance Key UserPermId UserPerm
instance Key UserRestoreId UserRestore
instance Key UserSingleUseCodeId UserSingleUseCode
data LevelDBEnv = LevelDBEnv !DB !ReadOptions !WriteOptions !RLock
newLevelDBEnv :: MonadIO m => DB -> ReadOptions -> WriteOptions -> m LevelDBEnv
newLevelDBEnv db rops wopts = do
rlock <- liftIO new
return $ LevelDBEnv db rops wopts rlock
load :: (MonadResource m, Key i a, SafeCopy a) => LevelDBEnv -> i -> m (Maybe a)
load (LevelDBEnv db ropts _ _) i = do
mbs <- get db ropts (encodeKey i)
return $ decodeExWith safeGet <$> mbs
store :: (MonadResource m, Key i a, SafeCopy a) => LevelDBEnv -> i -> a -> m ()
store (LevelDBEnv db _ wopts _) i a = put db wopts (encodeKey i) (runEncode $ safePut a)
remove :: (MonadResource m, Key i a) => LevelDBEnv -> i -> m ()
remove (LevelDBEnv db _ wopts _) i = delete db wopts (encodeKey i)
modify :: (MonadResource m, MonadMask m, Key i a, SafeCopy a) => LevelDBEnv -> i -> (a -> a) -> m ()
modify db@(LevelDBEnv _ _ _ mut) i f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do
ma <- load db i
case ma of
Nothing -> return ()
Just a -> store db i (f a)
modifyM :: (MonadResource m, MonadMask m, Key i a, SafeCopy a) => LevelDBEnv -> i -> (a -> m a) -> m ()
modifyM db@(LevelDBEnv _ _ _ mut) i f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do
ma <- load db i
case ma of
Nothing -> return ()
Just a -> store db i =<< f a
loadModel :: MonadResource m => LevelDBEnv -> m Model
loadModel db = do
mm <- load db modelId
return $ fromMaybe newModel mm
storeModel :: MonadResource m => LevelDBEnv -> Model -> m ()
storeModel db = store db modelId
modifyModel :: MonadResource m => LevelDBEnv -> (Model -> Model) -> m ()
modifyModel db f = do
m <- loadModel db
storeModel db $ f m
modifyModelM :: (MonadResource m, MonadMask m) => LevelDBEnv -> (Model -> m (Model, a)) -> m a
modifyModelM db@(LevelDBEnv _ _ _ mut) f = bracket_ (liftIO $ acquire mut) (liftIO $ release mut) $ do
m <- loadModel db
(m', a) <- f m
storeModel db m'
return a
getPagedList :: (MonadResource m, Ord i, Key i a, SafeCopy a) => LevelDBEnv -> Page -> PageSize -> Set i -> m ([WithId i a], Word)
getPagedList db p s is = do
let is' = take (fromIntegral s) . drop (fromIntegral $ p * s) . sort . F.toList $ is
es <- traverse (\i -> fmap (i,) <$> load db i) is'
return (fmap (uncurry WithField) . catMaybes $ es, fromIntegral $ F.length is)
insertRecord :: (MonadResource m, MonadMask m, Key i a, ConvertableKey i, Ord i, SafeCopy a)
=> Lens' Model Int64
-> Lens' Model (Set i)
-> a -> LevelDBEnv -> m i
insertRecord counterL registryL v db = modifyModelM db $ \m -> do
let
i = toKey $ view counterL m
m' = m & over counterL (+1)
& over registryL (S.insert i)
store db i v
return (m', i)
selectRecords :: (MonadResource m, Key i a, SafeCopy a)
=> Lens' Model (Set i)
-> (i -> a -> Bool)
-> LevelDBEnv -> m [WithId i a]
selectRecords registryL f db = do
is <- view registryL <$> loadModel db
fmap catMaybes $ forM (F.toList is) $ \i -> do
ma <- load db i
return $ case ma of
Just a | f i a -> Just $ WithField i a
_ -> Nothing
deleteRecords :: (MonadResource m, MonadMask m, Key i a, Ord i, Foldable f)
=> Lens' Model (Set i)
-> f i
-> LevelDBEnv -> m ()
deleteRecords registryL is db = modifyModelM db $ \m -> do
F.traverse_ (remove db) is
return . (, ()) $ m & over registryL (`S.difference` (S.fromList . F.toList) is)
replaceRecord :: (MonadResource m, MonadMask m, Key i a, Ord i, SafeCopy a)
=> Lens' Model (Set i)
-> i
-> a
-> LevelDBEnv -> m ()
replaceRecord registryL i v db = modifyModelM db $ \m -> do
store db i v
return . (, ()) $ m & over registryL (S.insert i)
withId :: WithField s i a -> i
withId (WithField i _) = i
withVal :: WithField s i a -> a
withVal (WithField _ v) = v
getUserImplByLogin :: MonadResource m => Login -> LevelDBEnv -> m (Maybe (WithId UserImplId UserImpl))
getUserImplByLogin login db = do
Model{..} <- loadModel db
case M.lookup login _modelUsersByLogin of
Nothing -> return Nothing
Just i -> fmap (WithField i) <$> load db i
listUsersPaged :: MonadResource m => Page -> PageSize -> LevelDBEnv -> m ([WithId UserImplId UserImpl], Word)
listUsersPaged p s db = getPagedList db p s =<< (_modelUsers <$> loadModel db)
getUserImplPermissions :: MonadResource m => UserImplId -> LevelDBEnv -> m [WithId UserPermId UserPerm]
getUserImplPermissions i = selectRecords modelUserPerms $ \ _ perm -> userPermUser perm == i
deleteUserPermissions :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()
deleteUserPermissions i db = do
is <- fmap withId <$> getUserImplPermissions i db
deleteRecords modelUserPerms is db
insertUserPerm :: (MonadResource m, MonadMask m) => UserPerm -> LevelDBEnv -> m UserPermId
insertUserPerm = insertRecord modelNextUserPermId modelUserPerms
insertUserImpl :: (MonadResource m, MonadMask m) => UserImpl -> LevelDBEnv -> m UserImplId
insertUserImpl v db = modifyModelM db $ \m -> do
let
i = toKey $ view modelNextUserImplId m
m' = m & over modelNextUserImplId (+1)
& over modelUsers (S.insert i)
& over modelUsersByLogin (M.insert (userImplLogin v) i)
store db i v
return (m', i)
replaceUserImpl :: (MonadResource m, MonadMask m) => UserImplId -> UserImpl -> LevelDBEnv -> m ()
replaceUserImpl i v db = modifyModelM db $ \m -> do
muser <- load db i
let cleanOld = case muser of
Nothing -> id
Just v' -> M.delete (userImplLogin v')
store db i v
return . (, ()) $ m & over modelUsersByLogin (M.insert (userImplLogin v) i . cleanOld)
deleteUserImpl :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()
deleteUserImpl i db = do
muser <- load db i
case muser of
Nothing -> return ()
Just u -> modifyModelM db $ \m -> do
deleteUserPermissions i db
remove db i
return . (, ()) $ m
& over modelUsers (S.delete i)
& over modelUsersByLogin (M.delete (userImplLogin u))
hasPerm :: MonadResource m => UserImplId -> Permission -> LevelDBEnv -> m Bool
hasPerm i p db = do
ps <- getUserImplPermissions i db
return $ (> 0) . F.length . filter (\(WithField _ p') -> userPermUser p' == i && userPermPermission p' == p) $ ps
getFirstUserByPerm :: MonadResource m => Permission -> LevelDBEnv -> m (Maybe (WithId UserImplId UserImpl))
getFirstUserByPerm perm db = do
ps <- view modelUserPerms <$> loadModel db
let
go _ v@Just{} = pure v
go i Nothing = do
mp <- load db i
case mp of
Just p | userPermPermission p == perm -> fmap (WithField (userPermUser p)) <$> load db (userPermUser p)
_ -> pure Nothing
F.foldrM go Nothing ps
selectUserImplGroups :: MonadResource m => UserImplId -> LevelDBEnv -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
selectUserImplGroups i = selectRecords modelAuthUserGroupUsers $ \_ g -> authUserGroupUsersUser g == i
clearUserImplGroups :: (MonadResource m, MonadMask m) => UserImplId -> LevelDBEnv -> m ()
clearUserImplGroups i db = do
is <- fmap withId <$> selectUserImplGroups i db
deleteRecords modelAuthUserGroupUsers is db
insertAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroup -> LevelDBEnv -> m AuthUserGroupId
insertAuthUserGroup = insertRecord modelNextAuthUserGroupId modelAuthUserGroups
insertAuthUserGroupUsers :: (MonadResource m, MonadMask m) => AuthUserGroupUsers -> LevelDBEnv -> m AuthUserGroupUsersId
insertAuthUserGroupUsers = insertRecord modelNextAuthUserGroupUserId modelAuthUserGroupUsers
insertAuthUserGroupPerms :: (MonadResource m, MonadMask m) => AuthUserGroupPerms -> LevelDBEnv -> m AuthUserGroupPermsId
insertAuthUserGroupPerms = insertRecord modelNextAuthUserGroupPermId modelAuthUserGroupPerms
listAuthUserGroupPermissions :: MonadResource m => AuthUserGroupId -> LevelDBEnv -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
listAuthUserGroupPermissions i = selectRecords modelAuthUserGroupPerms $ \_ p -> authUserGroupPermsGroup p == i
listAuthUserGroupUsers :: MonadResource m => AuthUserGroupId -> LevelDBEnv -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
listAuthUserGroupUsers i = selectRecords modelAuthUserGroupUsers $ \_ p -> authUserGroupUsersGroup p == i
replaceAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroupId -> AuthUserGroup -> LevelDBEnv -> m ()
replaceAuthUserGroup = replaceRecord modelAuthUserGroups
clearAuthUserGroupUsers :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()
clearAuthUserGroupUsers i db = do
is <- fmap withId <$> listAuthUserGroupUsers i db
deleteRecords modelAuthUserGroupUsers is db
clearAuthUserGroupPerms :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()
clearAuthUserGroupPerms i db = do
is <- fmap withId <$> listAuthUserGroupPermissions i db
deleteRecords modelAuthUserGroupPerms is db
deleteAuthUserGroup :: (MonadResource m, MonadMask m) => AuthUserGroupId -> LevelDBEnv -> m ()
deleteAuthUserGroup i db = modifyModelM db $ \m -> do
clearAuthUserGroupUsers i db
clearAuthUserGroupPerms i db
remove db i
return . (, ()) $ m & over modelAuthUserGroups (S.delete i)
listGroupsPaged :: MonadResource m => Page -> PageSize -> LevelDBEnv -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
listGroupsPaged p s db = getPagedList db p s =<< (view modelAuthUserGroups <$> loadModel db)
setAuthUserGroupName :: (MonadResource m, MonadMask m) => AuthUserGroupId -> Text -> LevelDBEnv -> m ()
setAuthUserGroupName i n db = modify db i $ \v -> v { authUserGroupName = n }
setAuthUserGroupParent :: (MonadResource m, MonadMask m) => AuthUserGroupId -> Maybe AuthUserGroupId -> LevelDBEnv -> m ()
setAuthUserGroupParent i p db = modify db i $ \v -> v { authUserGroupParent = p }
insertSingleUseCode :: (MonadResource m, MonadMask m) => UserSingleUseCode -> LevelDBEnv -> m UserSingleUseCodeId
insertSingleUseCode = insertRecord modelNextUserSingleUseCodeId modelUserSingleUseCodes
setSingleUseCodeUsed :: (MonadResource m, MonadMask m) => UserSingleUseCodeId -> Maybe UTCTime -> LevelDBEnv -> m ()
setSingleUseCodeUsed i mt db = modify db i $ \v -> v { userSingleUseCodeUsed = mt }
getUnusedCode :: MonadResource m => SingleUseCode -> UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
getUnusedCode c i t db = headMay . sorting <$> selectRecords modelUserSingleUseCodes f db
where
sorting = sortBy (comparing $ Down . userSingleUseCodeExpire . (\(WithField _ v) -> v))
f _ usc =
userSingleUseCodeValue usc == c
&& userSingleUseCodeUser usc == i
&& isNothing (userSingleUseCodeUsed usc)
&& (isNothing (userSingleUseCodeExpire usc) || userSingleUseCodeExpire usc >= Just t)
invalidatePermamentCodes :: (MonadResource m, MonadMask m) => UserImplId -> UTCTime -> LevelDBEnv -> m ()
invalidatePermamentCodes i t db = do
cs <- view modelUserSingleUseCodes <$> loadModel db
forM_ (F.toList cs) $ \cid -> do
mc <- load db cid
case mc of
Just usc | isPermament usc -> modify db cid invalidate
_ -> return ()
where
invalidate su = su { userSingleUseCodeUsed = Just t }
isPermament usc =
userSingleUseCodeUser usc == i
&& isNothing (userSingleUseCodeUsed usc)
&& isNothing (userSingleUseCodeExpire usc)
selectLastRestoreCode :: MonadResource m => UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserRestoreId UserRestore))
selectLastRestoreCode i t db = headMay . sorting <$> selectRecords modelUserRestores (const f) db
where
sorting = sortBy (comparing $ Down . userRestoreExpire . withVal)
f ur = userRestoreUser ur == i && userRestoreExpire ur > t
insertUserRestore :: (MonadResource m, MonadMask m) => UserRestore -> LevelDBEnv -> m UserRestoreId
insertUserRestore = insertRecord modelNextUserRestoreId modelUserRestores
findRestoreCode :: MonadResource m => UserImplId -> RestoreCode -> UTCTime -> LevelDBEnv -> m (Maybe (WithId UserRestoreId UserRestore))
findRestoreCode i rc t db = headMay . sorting <$> selectRecords modelUserRestores (const f) db
where
sorting = sortBy (comparing $ Down . userRestoreExpire . (\(WithField _ v) -> v ))
f ur = userRestoreUser ur == i && userRestoreValue ur == rc && userRestoreExpire ur > t
replaceRestoreCode :: (MonadResource m, MonadMask m) => UserRestoreId -> UserRestore -> LevelDBEnv -> m ()
replaceRestoreCode = replaceRecord modelUserRestores
findAuthToken :: MonadResource m => UserImplId -> UTCTime -> LevelDBEnv -> m (Maybe (WithId AuthTokenId AuthToken))
findAuthToken i t db = headMay <$> selectRecords modelAuthTokens (const f) db
where
f atok = authTokenUser atok == i && authTokenExpire atok > t
findAuthTokenByValue :: MonadResource m => SimpleToken -> LevelDBEnv -> m (Maybe (WithId AuthTokenId AuthToken))
findAuthTokenByValue v db = headMay <$> selectRecords modelAuthTokens (const f) db
where
f atok = authTokenValue atok == v
insertAuthToken :: (MonadResource m, MonadMask m) => AuthToken -> LevelDBEnv -> m AuthTokenId
insertAuthToken = insertRecord modelNextAuthTokenId modelAuthTokens
replaceAuthToken :: (MonadResource m, MonadMask m) => AuthTokenId -> AuthToken -> LevelDBEnv -> m ()
replaceAuthToken = replaceRecord modelAuthTokens
deriveSafeCopy 0 'base ''UserImplId
deriveSafeCopy 0 'base ''UserImpl
deriveSafeCopy 0 'base ''UserPermId
deriveSafeCopy 0 'base ''UserPerm
deriveSafeCopy 0 'base ''AuthTokenId
deriveSafeCopy 0 'base ''AuthToken
deriveSafeCopy 0 'base ''UserRestoreId
deriveSafeCopy 0 'base ''UserRestore
deriveSafeCopy 0 'base ''UserSingleUseCodeId
deriveSafeCopy 0 'base ''UserSingleUseCode
deriveSafeCopy 0 'base ''AuthUserGroupId
deriveSafeCopy 0 'base ''AuthUserGroup
deriveSafeCopy 0 'base ''AuthUserGroupUsersId
deriveSafeCopy 0 'base ''AuthUserGroupUsers
deriveSafeCopy 0 'base ''AuthUserGroupPermsId
deriveSafeCopy 0 'base ''AuthUserGroupPerms
deriveSafeCopy 0 'base ''ModelId
deriveSafeCopy 0 'base ''Model
instance (SafeCopy k, SafeCopy v) => SafeCopy (WithField i k v) where
putCopy a@(WithField k v) = contain $ do
_ <- safePut k
_ <- safePut v
return a
getCopy = contain $ WithField
<$> safeGet
<*> safeGet